فصل ملف اكسل اعتمادا على بيانات في ملف آخر

[أبو محمد المنار]

السلام عليكم ورحمة الله وبركاته

هذا الموضوع الموضوع مرتبط بهذا الموضوع  ولكن المثال كان بسيط

الملفان المرفقان يحتويان على:

• الملف الأول ملف معلومات "كل الموظفين" و عددهم اكثر من 100 و لكل موظف اكتر من 75 متغير - اسم الموظف ، رقمه .... الى المتغير رقم 75

• الملف الثاني هو الفورم الذي تنعكس فيه المعلومات السابقة.و يتوى على عدة اوراق عمل ويكون اسمه باسم الموظف.

و المطلوب ان يكون لكل موظف ملف كالملف الثاني.

و بارك الله فيكم وفي علمكم ووقتكم

كل الموظفين.zip

[ياسر خليل أبو البراء]

أخي الكريم المنار

يفضل في مثل تلك الموضوعات التي تستغرق الكثير من الوقت والجهد أن تكون الملفات المرفقة معبرة أكثر من ذلك .. وبالنسبة للمصنف المسمى اسم الموظف هو بنفس التنسيق تماماً الذي تريد العمل عليه أم أنه يختلف

ويا ريت تضع عناوين حقيقية بدلاً من كلمة المتغير .. وبعض البيانات لمحاولة التطبيق عليها

[أبو محمد المنار]

 المصنف المسمى اسم الموظف هو  بنفس التنسيق تماماً الذي نريد العمل عليه.

[ياسر خليل أبو البراء]

أخي الفاضل المنار

لم تستجب لمطلبي ..عموماً قمت بالعمل على ورقة عمل واحدة فقط ليطمئن قلبك أن الأمر ممكن ..

قمت بالتغيير قليلا في ملف الـ Template الذي يعتبر بمثابة النموذج المراد العمل عليه

إليك الملف التالي .. ويمكنك الإضافة إلى الكود بحيث يشمل أي بيانات ..

اكتفيت بورقة العمل الأولي فقط

Sub SplitWB()
    Dim WBK As Workbook
    Dim Cell As Range
    Dim strPath As String
    Dim I As Long, Arr
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        Arr = ThisWorkbook.Sheets("Sheet1").Cells(1).CurrentRegion.Value
        For I = 2 To UBound(Arr, 1)
            strPath = ThisWorkbook.Path & "\"
            FileCopy strPath & "Template.xlsx", strPath & Arr(I, 2) & ".xlsx"
            Set WBK = Workbooks.Open(strPath & Arr(I, 2) & ".xlsx")
            
            With WBK
               With .Sheets("المعلومات الاساسية")
                    ThisWorkbook.Activate
                   .Range("B3").Resize(15, 1) = Application.Transpose(Array(ThisWorkbook.Sheets("Sheet1").Range(Cells(I, 2), Cells(I, 16))))
                   .Range("A19") = Arr(I, 17)
                   .Range("A21") = Arr(I, 18)
                   .Range("A23") = Arr(I, 19)
               End With
               
               .Close SaveChanges:=True
           End With
        Next I
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "تم بحمد الله .. قل سبحان الله وبحمده سبحان الله العظيم", vbInformation
End Sub

تقبل تحياتي

Copy Workbook Template & Name It By Employee YasserKhalil.rar