اضافة الى كود الاستاذ محى الدين ابو البشر

[فوزى فوزى]

السلام عليكم ورحمة الله وبركاته عباقرة منتدى اوفيسنا الأعزاء الشيت به كود للمبدع الأستاذ محى الدين أبو البشر وهو كود يقوم بعمله على اكمل وجه ولكن ورد الينا تعليمات جديدة ان يكون الادخال معتمد على رقم اللجنة وعدد الأعضاء داخل كل لجنة بمعنى كان الادخال عدد الترحيل كان معتمد على الخلية F2 وكان الكود يرحل ممتاز ولا يعيبه شئ ولكن الان سيتم ادخال البيانات عن طريق عمود رقم اللجنة وعمود العدد المطلوب ترحيله بمعنى ان اكتب لجنة رقم 1 والعدد المطلوب ترحيله 23 يرحل الى الكشف الاول 23 اسم من رقم اللجنة 1 وكتبت مرة رقم اللجنة 1 العدد المطلوب ترحيله 20 اذا يرحل فى كشف الثانى 20 اسم من لجنة رقم 1 وهكذا الترحيل يكون من التقرير الى شيت كشف الطباعة وجعلكم الله عونا لنا وللامثالنا

ترحيل الاسماء (2).xlsm

[محي الدين ابو البشر]

تفضل أخي الكريم

ربما؟

Sub test2()
Dim ws As Worksheet: Set ws = Sheets("التقرير")
Dim sh As Worksheet: Set sh = Sheets("كشف الطباعة")
Dim a, b, w
Dim i&, c&, ii&, kk&
Dim r As Range
Dim f As String
a = ws.Range(ws.Cells(6, 1), ws.Cells(6, 4).End(xlDown))
b = ws.Range(ws.Cells(6, 6), ws.Cells(6, 7).End(xlDown))
With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
                If Not .exists(a(i, 4)) Then
                .Add a(i, 4), Array(a(i, 1), a(i, 2), a(i, 3))
                Else
                w = Application.Transpose(.Item(a(i, 4)))
                ReDim Preserve w(1 To UBound(w), 1 To UBound(w, 2) + 1)
                w = Application.Transpose(w)
                For ii = 1 To 3
                w(UBound(w), ii) = a(i, ii)
                Next
                .Item(a(i, 4)) = w
                End If
        Next
    Set r = sh.Columns("a").Find("م", , , 1)
    If Not r Is Nothing Then
     f = r.Address: i = 1
        Do
            w = .Item(.Keys()(kk))
1       [r].Offset(1).Resize(25, 3).ClearContents
         [r].Offset(1).Resize(b(i, 2), 3) = Application.IfError(Application.Index(w, _
            Evaluate("Row(" & 1 + c & ":" & c + b(i, 2) & ")"), [{1, 2,3}]), "")
            If i = UBound(b) Then Exit Sub
            If b(i, 1) = b(i + 1, 1) Then
                 Set r = sh.Columns("a").FindNext(r)
                 c = c + b(i, 2): i = i + 1
                 GoTo 1
                 Else: GoTo 2
                 End If
2            kk = kk + 1: i = i + 1: c = 0
             Set r = sh.Columns("a").FindNext(r)
        Loop Until r.Address = f
    End If
End With
End Sub

 

ترحيل أسماء.xlsm

[فوزى فوزى]

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

[محي الدين ابو البشر]

بارك الله