تصحيح كود الترحيل إلى عدة صفحات بشرط اسم الصفحة

[حاتم عيسى]

السلام عليكم ورحمة الله وبركاته عندي ملف به بيانات العاملين في عدة أقسام مختلفة

هل من الممكن أن يتم عمل صفحة تلقائيا بناء على اسم القسم وترحيل البيانات الخاصة بالعاملين بهذا القسم إلى تلك الصفحة مع عدم تكرار البيانات

مرفق الملف المراد العمل عليه .... وجزاكم الله خيرا ونفعكم الله بعلمكم وزادكم علما

2051820742_.xlsm

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

حسب المرفق جرب هذا الكود ... وضعه فى مديول جديد

Sub Distribute()
    Dim ws As Worksheet, wb As Workbook
    Dim a, e, i As Long, ii As Long, w, x
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        Set ws = Sheet1
        Application.Calculation = xlManual
        a = Intersect(ws.Rows("4:" & Rows.Count), _
                      ws.Range("b4").CurrentRegion).Columns("b:as").Value
        ReDim w(1 To UBound(a, 2))
        For i = 1 To UBound(a, 1)
            If a(i, 1) = "" Then Exit For
            If Not .exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
            End If
            If Not .Item(a(i, 1)).exists(a(i, 1)) Then
                ReDim x(1 To 2)
                Set x(1) = CreateObject("System.Collections.ArrayList")
                Set x(2) = Intersect(ws.Rows("5:" & Rows.Count), _
                                     ws.Range("a4").CurrentRegion).Columns("a:as")
                .Item(a(i, 1))(a(i, 1)) = x
            End If
            For ii = 2 To UBound(a, 2)
                w(ii) = a(i, ii)
            Next
            .Item(a(i, 1))(a(i, 1))(1).Add w
        Next
        For Each e In .keys
            For i = 0 To .Item(e).Count - 1
                w = Application.Index(.Item(e).items()(i)(1).ToArray, 0, 0)
                With Sheets(e)
                    .Cells(4, 1).Resize(UBound(w, 1), UBound(w, 2)) = w
                    .Cells(4, 1).FormulaR1C1 = "1"
                    .Cells(4, 1).Resize(UBound(w)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
                End With
            Next
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
End Sub

245472506_.xlsm

[حاتم عيسى]

الأستاذ : محي الدين ابو البشر المحترم

شكرا جزيلا لحضرتك على سرعة الرد وجزاك الله خيرا

 

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

وشكراً لك

[حاتم عيسى]

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

كيف يمكن زيادة عدد الصفحات التي يتم الترحيل إليها ؟

تم تعديل نوفمبر 30, 2020 بواسطه حاتم عيسى

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

 

عند  الإضاقة قي عمود <<القسم / التوجيه>> فقط أنشى صفحات بنفس الأسماء المضاقة