ورقة عمل حسب اسم الخلايا

[ابو ذكري]

New Microsoft Excel Worksheet - Copy.xlsx

السلام عليكم

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

برجاء الافادة

تم تعديل منذ 6 ساعات بواسطه ابو ذكري

[hegazee]

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

استخدم الكود التالي

Sub CreateSheetsFromList()
    Dim ws As Worksheet
    Dim cell As Range
    Dim newSheet As Worksheet
    Dim shName As String
    
    ' الورقة اللي فيها الأسماء
    Set ws = ThisWorkbook.Sheets("Sheet3") ' غير اسم الورقة حسب ملفك
    
    ' المرور على العمود A
    For Each cell In ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        If Trim(cell.Value) <> "" Then
            shName = Trim(cell.Value)
            On Error Resume Next
            ' التأكد إنه مفيش ورقة بنفس الاسم
            Set newSheet = ThisWorkbook.Sheets(shName)
            On Error GoTo 0
            If newSheet Is Nothing Then
                ' إنشاء ورقة جديدة بالاسم
                ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = shName
            End If
            Set newSheet = Nothing
        End If
    Next cell
    
    MsgBox "تم إنشاء الأوراق بنجاح", vbInformation
End Sub

 

New.xlsm