تقسيم ملف حسب عدد الصفوف لعدة ملفات منفصلة

[مصطفى شاهين]

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

عندي ملف إكسيل، به مجموعة كبيرة من البيانات ما يقارب 3000 صف، مثل: (الاسم، رقم الهوية، رقم الموبايل، العنوان....)، مطلوب مني تقسيمهم كل 30 صف ببياناته كاملاً بملف منفصل، بمعنى من 1-30 ملف لوحده، من 31-60 ملف لوحده، 61-90 ملف لوحده، وهكذا.

هل يمكن عمل ذلك؟

ولكم مني كل الاحترام والتقدير

[محمد هشام.]

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

نعم يمكننا اخي فعل دالك ارفق ملفك او نمودج لشكل البيانات لديك على الملف لتحديد النطاق المطلوب 

[أ / محمد صالح]

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

نعم، يمكن القيام بذلك باستخدام VBA في Excel. إليك كود VBA الذي يمكنك استخدامه لتقسيم البيانات إلى ملفات منفصلة كل 30 صف:

1. افتح ملف Excel واضغط على Alt + F11 لفتح محرر VBA.
2. أدخل الكود التالي في وحدة جديدة:

Sub SplitDataIntoFiles()
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim wb As Workbook
    Dim newWb As Workbook
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim filePath As String
    
    Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من أن اسم الورقة صحيح
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    filePath = ThisWorkbook.Path & "\"
    
    j = 1
    For i = 1 To lastRow Step 30
        Set newWb = Workbooks.Add
        Set newWs = newWb.Sheets(1)
        
        ws.Rows(i & ":" & i + 29).Copy Destination:=newWs.Rows(1)
        
        newWb.SaveAs filePath & "Data_" & j & ".xlsx"
        newWb.Close SaveChanges:=False
        j = j + 1
    Next i
    
    MsgBox "تم تقسيم البيانات بنجاح!",,"mr-mas.com"
End Sub

3. قم بتعديل اسم الورقة في السطر Set ws = ThisWorkbook.Sheets("Sheet1") إذا كان مختلفًا.
4. اضغط على F5 لتشغيل الكود.

سيقوم هذا الكود بتقسيم البيانات إلى ملفات منفصلة كل 30 صف وحفظها في نفس مسار الملف الأصلي.

بالتوفيق

[مصطفى شاهين]

2 ساعات مضت, أ / محمد صالح said:

سيقوم هذا الكود بتقسيم البيانات إلى ملفات منفصلة كل 30 صف وحفظها في نفس مسار الملف الأصلي.

 

أ / محمد صالح

بارك الله فيك أخي الكريم، تمت العملية على ما يرام، والتقسيم حسب المطلوب تماماً.

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

دمتم بخير

2 ساعات مضت, محمد هشام. said:

نعم يمكننا اخي فعل دالك ارفق ملفك او نمودج لشكل البيانات لديك على الملف لتحديد النطاق المطلوب 

أ. محمد هشام

بارك الله فيك، وعلى مبادرتكم الطيبة والسرعة في الرد، ما شاء الله تبارك الرحمن.

تم استخدام الكود الذي أرسله أ. محمد صالح، والأمور سارت على ما يرام.

أشكر لك جهودك الطيبة

دمتم بخير

[محمد هشام.]

يسعدنا انك حصلت على طلبك 

اليك حل اخر للفائدة فقط مع نسخ الملفات في مجلد في نفس مسار الملف الرئيسي 

Sub SplitData()
    Dim f As Worksheet, newWb As Workbook
    Dim DataRng As Range, newWs As Worksheet
    Dim rowCount As Long, startRow As Long, endRow As Long
    Dim WSname As String, folderPath As String
    Dim Cnt As Long, FolderName As String
    
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .CopyObjectsWithCells = False
    End With

    Set f = ThisWorkbook.Sheets(1)
    rowCount = f.Cells(f.Rows.Count, "A").End(xlUp).Row
    startRow = 2
    Cnt = 0
    FolderName = "تقسيم"
    folderPath = ThisWorkbook.Path & "\" & FolderName & "\"

    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    End If

    Do While startRow <= rowCount
        endRow = startRow + 29
        If endRow > rowCount Then endRow = rowCount
      '******** قم بتعديل نطاق الاعمدة بما يناسبك
        Set DataRng = f.Range("A" & startRow & ":D" & endRow)
        Set newWb = Workbooks.Add
        Set newWs = newWb.Sheets(1)
        f.Range("A1:D1").Copy newWs.Range("A1:D1")
        DataRng.Copy newWs.Range("A2")
        For col = 1 To f.Cells(1, f.Columns.Count).End(xlToLeft).Column
            newWs.Columns(col).ColumnWidth = f.Columns(col).ColumnWidth
        Next col
        WSname = "Part_" & " " & (startRow - 1) & "-" & (endRow - 1) & ".xlsx"
        newWb.SaveAs folderPath & WSname
        newWb.Close False
        
        startRow = endRow + 1
        Cnt = Cnt + 1
    Loop

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .CopyObjectsWithCells = True
    End With

    MsgBox "تم استخراج " & Cnt & " ملف", vbInformation, "تقسيم الملفات"
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical, "خطأ"
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[مصطفى شاهين]

2 دقائق مضت, محمد هشام. said:

يسعدنا انك حصلت على طلبك 

اليك حل اخر للفائدة فقط مع نسخ الملفات في مجلد في نفس مسار الملف الرئيسي 

وأنا يسعدني جداً تعاونكم الخالص دون كلل أو ملل، جعل الله هذا العمل  في ميزان حسناتكم إلى يوم الدين

بارك الله فيكم، وعلى المعلومة القيمة، وحقيقة مفيدة جداً

بوركت

[محمد هشام.]

وهدا للتقسيم بشرط خلية معينة مثلا E1  يمكنك تعديلها بما يناسبك 

Sub test2()
    Dim f As Worksheet, newWb As Workbook
    Dim DataRng As Range, newWs As Worksheet
    Dim rowCount As Long, startRow As Long, endRow As Long
    Dim rowLimit As Long
    Dim WSname As String, folderPath As String
    Dim Cnt As Long, FolderName As String
    
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .CopyObjectsWithCells = False
    End With

    Set f = ThisWorkbook.Sheets(1)
    rowCount = f.Cells(f.Rows.Count, "A").End(xlUp).Row
    startRow = 2
    Cnt = 0
    FolderName = "تقسيم"
    folderPath = ThisWorkbook.Path & "\" & FolderName & "\"

    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    End If
    ' خلية تحديد عدد الصفوف
    rowLimit = f.Range("E1").Value
    Do While startRow <= rowCount
        endRow = startRow + rowLimit - 1
        If endRow > rowCount Then endRow = rowCount
        
        Set DataRng = f.Range("A" & startRow & ":D" & endRow)
        Set newWb = Workbooks.Add
        Set newWs = newWb.Sheets(1)
        
        f.Range("A1:D1").Copy newWs.Range("A1:D1")
        DataRng.Copy newWs.Range("A2")
          For col = 1 To f.Cells(1, f.Columns.Count).End(xlToLeft).Column
            newWs.Columns(col).ColumnWidth = f.Columns(col).ColumnWidth
        Next col
        WSname = "Part_" & " " & (startRow - 1) & "-" & (endRow - 1) & ".xlsx"
        newWb.SaveAs folderPath & WSname
        newWb.Close False
        
        startRow = endRow + 1
        Cnt = Cnt + 1
    Loop

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .CopyObjectsWithCells = True
    End With

    MsgBox "تم استخراج " & Cnt & " ملف", vbInformation, "تقسيم الملفات"
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical, "خطأ"
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

 

[مصطفى شاهين]

2 دقائق مضت, محمد هشام. said:

وهدا للتقسيم بشرط خلية معينة مثلا E1  يمكنك تعديلها بما يناسبك 

يا سلام على الكرم، زادك الله علماً، جربت الكود السابق، تم التقسيم بملف منفصل كل 30 صف لوحده، ويحمل اسم part-1-30، والملف الآخر كذلك، الله يسعدك، ما قصرت

أشكرك جزيل الشكر