تعديل الكود ليجعل التسلسل في صفحة القائمة بالجنب وليس لأسفل

[سيد الأكرت]

السلام عليكم ورحمة الله وبركاته هذا الكود للاستاذ ياسر خليل حفظه الله لعمل قائمة 80 اسم ونظرا لزيادة الكثافات تم تعديله ل160 اسم لكنه يجعل التسلسل لاسفل في الصفحتين والمطلوب ان يكون التسلسل بالجنب في صفحة واحدة بمعنى ان يكون الاسم رقم 81 في رقم 41 وهكذا 

تعديل كود القوائم.xls

[أ / محمد صالح]

إن شاء الله يفيدك هذا التعديل

Sub قائمة80()
Dim Ws As Worksheet, Sh As Worksheet
Dim I As Long, x As Long, n As Long, Lr As Long

Set Ws = Sheets("السجل الكلي"): Set Sh = Sheets("قوائم80")
Lr = Ws.Cells(Rows.Count, 4).End(xlUp).Row

Application.ScreenUpdating = False
Sh.Range("C7:F86,H7:K86").ClearContents

For t = 1 To 2
    x = (t - 1) * 40 + 7
    For I = n + 9 To Lr
        If Ws.Cells(I, 6).Value = Sh.Range("D1").Value And Ws.Cells(I, 7).Value = Sh.Range("E1").Value Then
            Sh.Cells(x, 3).Value = Ws.Cells(I, 4).Value
            Sh.Cells(x, 4).Resize(1, 2).Value = Ws.Cells(I, 10).Resize(1, 2).Value
            Sh.Cells(x, 6).Value = Ws.Cells(I, 13).Value
            If x = t * 40 + 6 Then n = I + 1: Exit For
            x = x + 1
        End If
    Next I
    x = (t - 1) * 40 + 7
    For I = n To Lr
        If Ws.Cells(I, 6).Value = Sh.Range("D1").Value And Ws.Cells(I, 7).Value = Sh.Range("E1").Value Then
            Sh.Cells(x, 8).Value = Ws.Cells(I, 4).Value
            Sh.Cells(x, 9).Resize(1, 2).Value = Ws.Cells(I, 10).Resize(1, 2).Value
            Sh.Cells(x, 11).Value = Ws.Cells(I, 13).Value
            If x = t * 40 + 6 Then n = I - 8: Exit For
            x = x + 1
        End If
    Next I
Next t
Application.ScreenUpdating = True
MsgBox "Done...", 64
End Sub

بالتوفيق 

[سيد الأكرت]

جزاك الله خيرا اخي الكريم تم تعديل الكود بنجاح 

[أ / محمد صالح]

ويمكن اختصار الكود إلى

Sub mas160menu()
Dim Ws As Worksheet, Sh As Worksheet
Dim I As Long, x As Long, n As Long, Lr As Long, c As Integer
Set Ws = Sheets("السجل الكلي"): Set Sh = Sheets("قوائم80")
Lr = Ws.Cells(Rows.Count, 4).End(xlUp).Row
Application.ScreenUpdating = False
Sh.Range("C7:F86,H7:K86").ClearContents
For t = 1 To 2
1: x = (t - 1) * 40 + 7
For I = n + 9 To Lr
If Ws.Cells(I, 6).Value = Sh.Range("D1").Value And Ws.Cells(I, 7).Value = Sh.Range("E1").Value Then
Sh.Cells(x, IIf(c Mod 2, 8, 3)).Value = Ws.Cells(I, 4).Value
Sh.Cells(x, IIf(c Mod 2, 9, 4)).Resize(1, 2).Value = Ws.Cells(I, 10).Resize(1, 2).Value
Sh.Cells(x, IIf(c Mod 2, 11, 6)).Value = Ws.Cells(I, 13).Value
If x = t * 40 + 6 Then
n = I - 8: c = c + 1
If c Mod 2 Then
GoTo 1
Else
GoTo 2
End If: End If
x = x + 1: n = I + 1
End If
Next I
2: Next t
Application.ScreenUpdating = True
MsgBox "Done by mr-mas.com"
End Sub

ويجب إعادة تعيين الماكرو للزر مع الاسم الجديد

وهذا ملفك بعد التعديل .. بالتوفيق

تعديل كود القوائم.xls

[سيد الأكرت]

ما شاء الله رووووعة