كود تقسيم ورقة العمل بستخدام الذكاء الصناعي

[احمد بن ابراهيم]

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

زملائي المبدعين

اليوم احببت ان اطلب من Chat GPT عمل كود VBA  يعمل على تقسيم  بيانات ورقة عمل حسب اختياري للعامود على شكل اوراق عمل ( SHEET) منفصلة باسم البيان ثم يفصل كل ورقة عمل اكسل داخل مجلد باسم البيان .

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

Sub SplitDataBySelectedColumn()

    Dim wsSource As Worksheet

    Dim wsNew As Worksheet

    Dim rng As Range

    Dim cell As Range

    Dim dict As Object

    Dim key As Variant

    Dim lastRow As Long

    Dim header As Range

    Dim colToSplit As String

    Dim colLetter As String

    Dim colNum As Long

   

    ' طلب العمود من المستخدم

    colToSplit = InputBox("أدخل حرف العمود الذي تريد الفصل بناءً عليه (مثل D):", "اختيار العمود")

   

    If colToSplit = "" Then

        MsgBox "تم الإلغاء.", vbExclamation

        Exit Sub

    End If

   

    colToSplit = UCase(colToSplit)

   

    ' تحديد ورقة العمل الحالية كمصدر

    Set wsSource = ActiveSheet

   

    ' تحديد آخر صف في العمود المحدد

    lastRow = wsSource.Cells(wsSource.Rows.Count, colToSplit).End(xlUp).Row

   

    ' تحديد نطاق البيانات

    Set header = wsSource.Rows(1)

    Set rng = wsSource.Range("A2:" & wsSource.Cells(lastRow, wsSource.Columns.Count).End(xlToLeft).Address)

   

    ' إنشاء قاموس للقيم الفريدة

    Set dict = CreateObject("Scripting.Dictionary")

   

    ' جمع القيم الفريدة من العمود المحدد

    For Each cell In wsSource.Range(colToSplit & "2:" & colToSplit & lastRow)

        If Not dict.exists(cell.Value) And Trim(cell.Value) <> "" Then

            dict.Add cell.Value, Nothing

        End If

    Next cell

   

    Application.ScreenUpdating = False

   

    ' إنشاء شيت لكل قيمة فريدة

    For Each key In dict.keys

        ' التحقق من وجود الشيت مسبقًا

        Set wsNew = Nothing

        On Error Resume Next

        Set wsNew = ThisWorkbook.Sheets(CStr(key))

        On Error GoTo 0

       

        If wsNew Is Nothing Then

            Set wsNew = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))

            wsNew.Name = Left(CStr(key), 31) ' الحد الأقصى لاسم الشيت 31 حرف

        End If

       

        wsNew.Cells.Clear

       

        ' نسخ العناوين

        header.Copy Destination:=wsNew.Range("A1")

       

        ' تصفية البيانات حسب القيمة الحالية

        wsSource.Rows(1).AutoFilter Field:=wsSource.Range(colToSplit & "1").Column, Criteria1:=key

        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=wsNew.Range("A2")

    Next key

   

    ' إلغاء التصفية

    wsSource.AutoFilterMode = False

    Application.CutCopyMode = False

    Application.ScreenUpdating = True

   

    MsgBox "? تم إنشاء الشيتات بنجاح بحسب العمود " & colToSplit, vbInformation

End Sub

 

الشرقية.xlsm

[عبدالله بشير عبدالله]

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

جرب التعديل التالي 

الشرقية1.xlsm