تكرار كلمة عموديا

[صقر الخليج]

مرحبا اريد ان تتكرر الكلمة اسفل العمود بمكان الارقام اسفلها وعندما تتنهي الكلمة تكون الكلمة التالية بعدها ايضا تحل محل الارقام اسفلها وهكذا هل هنالك كود لحل هذه الطريقة خاصة اذا كانت السجلات مئة الف سجل تقريبا

فهرس الكتب الورقية موضوعيا.rar

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit

Sub test()
Dim Ro%, Rg As Range
Dim x%, t%, i%
With Sheets("ورقة1")
Ro = .Cells(Rows.Count, 1).End(3).Row
Set Rg = .Range("A1:A" & Ro).SpecialCells(2, 23)
     .Range("E1").Resize(Ro, 2).Clear
t = 1
For x = 1 To Rg.Areas.Count
     .Cells(t, "E").Resize(Rg.Areas(x).Rows.Count) = _
     Rg.Areas(x).Cells(1, 1)
     .Cells(t, "E").Interior.ColorIndex = 6
       For i = 2 To Rg.Areas(x).Rows.Count
           .Cells(t + 1, "F").Offset(i - 2) = _
           Rg.Areas(x).Cells(i).Offset(, 2)
       Next i
    t = t + Rg.Areas(x).Rows.Count + 1
Next x
    With .Range("E1").Resize(Ro, 2).SpecialCells(2, 23)
    .Borders.LineStyle = 1
    .Font.Bold = True
    .InsertIndent 1
    End With
End With
End Sub

الملف مرفق

Sakr_Khalige.xls

[صقر الخليج]

احسنتم الكود جميل جدا ولكنني اريده على الاقل 10000  سجل وهذا هو المثال جاهزممكن يكون التغيير في نفس السجلات وهذا المثال المرفق مع الصورة توضيحية

الفهرس كامل .rar

[سليم حاصبيا]

الملف الذي رفعته انت لا يشبه بأي شكل الملف الذي رفعته لك انا

[صقر الخليج]

نعم صحيح هذا هو الملف كاملا بواقع 10000 سجل وبنفس التنسيق السابق 

 

السؤال كاملا.rar

[سليم حاصبيا]

ابن هو التنسيق السابق؟؟؟؟

[صقر الخليج]

نعم هذا الملف مطابق لكل التنسيق وهو يعمل جيدا فقط تعديل به هو سجلات لحد 61000 سجل واضافة ثلاثة حقول على اليسار وهي f e d  اذا امكن مع صورة لتوضيح طلبي المتواضع واسف على الاطالة 

Sakr_Khalige.rar

[سليم حاصبيا]

استبدل الى هذا الماكرو (عليك الانتطار قليلاً حوالي الدقيقة كي يكمل الماكرو عمله) بسبب كثرة الداتا

Option Explicit

Sub test()
Dim Ro As Long, Rg As Range
Dim x As Long, t As Long, i As Long
    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    End With
With Sheets("ورقة1")
Ro = .Cells(Rows.Count, 1).End(3).Row
Set Rg = .Range("A1:A" & Ro).SpecialCells(2, 23)
     .Range("E1").Resize(Ro, 2).Clear
t = 1
For x = 1 To Rg.Areas.Count
     .Cells(t, "E").Resize(Rg.Areas(x).Rows.Count) = _
     Rg.Areas(x).Cells(1, 1)
     .Cells(t, "E").Interior.ColorIndex = 6
       For i = 2 To Rg.Areas(x).Rows.Count
           .Cells(t + 1, "F").Offset(i - 2) = _
           Rg.Areas(x).Cells(i).Offset(, 2)
       Next i
    t = t + Rg.Areas(x).Rows.Count + 1
Next x
    With .Range("E1").Resize(Ro, 2).SpecialCells(2, 23)
    .Borders.LineStyle = 1
    .Font.Bold = True
    .InsertIndent 1
    End With
End With
 With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
   End With
End Sub

الملف مرفق

Sk_Khalige.xlsm

[صقر الخليج]

ممتاز جدا ولكنني اود تحويل 6 اعمدة الى الجانب الاخر وليس فقط عمودين ممكن ذلك هذه الصورة مع المثال التوضيح وشكرا جزيلا يعني اريد تحويل اضافة الى المعالجة الحالية النصوص الموجودة في العمود المجلد والعنوان والناشر ورقم التصنيف 

 

 

17 10 2020.rar

تم تعديل أكتوبر 19, 2020 بواسطه صقر الخليج

[سليم حاصبيا]

ليس من الضروري رفع الملف بكامله (أكثر من 1000 صف) كان يكفي نبذة صغيرة عنه (حوالي 20 صف)

    لأن الماكرو الذي يعمل على صف واحد يمكنه العمل على الالوف

تم معالجة الأمر (مع التتغيير الى البيانات الضغيرة نسبياُ لمشاهذة عمل لماكرو بشكل جيد لأنه ليس من الضروري ان اقرأ اسم كل كتاب و مؤلفه
         و ما الى ذلك يكفي ان الاجظ الاحرف  A / B/ C  ان كانت في مكانها الصحيح)

يمكنك نسخ الكود الى الملف عندك وتنقيذه مع مراعاة تغيير اسم الصفخة في الماكرو من  Salim   الى الاسم الذي عندك

Sub Salim_Test()
Dim Ro As Long, Rg As Range
Dim x As Long, t As Long, i As Long, k%
    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    End With
With Sheets("Salim")
Ro = .Cells(Rows.Count, 1).End(3).Row
Set Rg = .Range("A2:A" & Ro).SpecialCells(2, 23)
     .Range("H2").Resize(Ro, 6).Clear
t = 2
For x = 1 To Rg.Areas.Count
        .Cells(t, "H").Resize(Rg.Areas(x).Rows.Count) = _
        Rg.Areas(x).Cells(1, 1)
        .Cells(t, "H").Interior.ColorIndex = 6
        .Cells(t + 1, "I"). _
        Resize(Rg.Areas(x).Rows.Count - 1, 5).Value = _
        Rg.Areas(x).Cells(2).Offset(, 1). _
        Resize(Rg.Areas(x).Rows.Count - 1, 5).Value
    t = t + Rg.Areas(x).Rows.Count + 1
Next x
    With .Range("H2").Resize(Ro, 6).SpecialCells(2, 23)
    .Borders.LineStyle = 1
    .Font.Bold = True
    .InsertIndent 1
    .Columns.AutoFit
    End With
End With
  With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
   End With

End Sub

 

Sk_Khalige_Six.xlsm

[صقر الخليج]

احسنت استاذ جعلها الله في ميزان حسناتك الله ادفع البلاء والوباء عن امتنا الاسلامية شكرا جزيلا