حساب عدد الحقول ونقل كل 100 صف في شيت ثاني

[ابو هاله النبلسي]

السلام عليكم ادناه  ملف احتاج حساب كل 100 صف ونقله في شيت ثاني 

تقسيم.xlsx

تم تعديل فبراير 23, 2023 بواسطه ابو هاله النبلسي

[lionheart]

Can you spot the desired results? Do you want to split every 100 rows of data only or what exactly

[ابو هاله النبلسي]

 YES I NEDD split every 100 rows of data only   IN NEW SHEET

[lionheart]

Try this code

Const numRows As Long = 100

Sub Test()
    Dim dataArray(), subArrays(), sheetNames() As String, ws As Worksheet, srcSheet As Worksheet, newSheet As Worksheet, dataRange As Range, sheetName As String, lr As Long, i As Long, j As Long, k As Long, cnt As Long, startRow As Long, endRow As Long
    Application.ScreenUpdating = False
        For Each ws In ThisWorkbook.Worksheets
            If Left(ws.Name, 1) = "T" And IsNumeric(Right(ws.Name, Len(ws.Name) - 1)) Then
                Application.DisplayAlerts = False
                    ws.Delete
                Application.DisplayAlerts = True
            End If
        Next ws
        Set srcSheet = ThisWorkbook.Worksheets(1)
        lr = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
        Set dataRange = srcSheet.Range("A2:D" & lr)
        dataArray = dataRange.Value
        subArrays = SplitArray(dataArray)
        cnt = 1
        ReDim sheetNames(1 To UBound(subArrays))
        For i = 1 To UBound(subArrays)
            Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            With newSheet
                .DisplayRightToLeft = True
                sheetName = "T" & cnt
                .Name = sheetName
                sheetNames(i) = sheetName
                srcSheet.Rows(1).Copy Destination:=.Rows(1)
                startRow = (i - 1) * numRows + 1
                endRow = WorksheetFunction.Min(i * numRows, UBound(subArrays(i)))
                For j = 1 To UBound(subArrays(i), 1)
                    For k = 1 To UBound(subArrays(i), 2)
                        .Cells(j + 1, k).Value = subArrays(i)(j, k)
                    Next k
                Next j
                cnt = cnt + 1
                .Range("A1").CurrentRegion.Columns.AutoFit
            End With
        Next i
    Application.ScreenUpdating = True
End Sub

Public Function SplitArray(ByVal arr)
    Dim numRecords As Long, numArrays As Long, i As Long, j As Long, ii As Long, startRow As Long, endRow As Long
    numRecords = UBound(arr, 1)
    numArrays = WorksheetFunction.Ceiling(numRecords / numRows, 1)
    ReDim subArrays(1 To numArrays)
    For i = 1 To numArrays
        startRow = (i - 1) * numRows + 1
        endRow = WorksheetFunction.Min(i * numRows, numRecords)
        ReDim subArray(1 To endRow - startRow + 1, 1 To UBound(arr, 2))
        For j = startRow To endRow
            For ii = LBound(arr, 2) To UBound(arr, 2)
                subArray(j - startRow + 1, ii) = arr(j, ii)
            Next ii
        Next j
        subArrays(i) = subArray
    Next i
    SplitArray = subArrays
End Function

 

[ابو هاله النبلسي]

 how add number like 100 in cell E1 SO AS TO RUN COD 

تقسيم.xlsx

[محمد هشام.]

 هل تقصد توزيع الصفوف بشرط قيمة خلية معينة ادا كان كدالك ما هي الخلية المطلوبة

[ابو هاله النبلسي]

سيدي في حالة وضعنا 100 في خليه E1 يتم تقسيم كل 100 اسم في شيت واحد واذا وضعنا 200 يتم تقسيم الاسماء كل 200 اسم في شيت وهكذا

[محمد هشام.]

بعد ادن الاستاد @lionheart 

 اخي @ابو هاله النبلسي تم تعديل بسيط على الكود  لتتمكن من تنفيد المطلوب 

 

تقسيم_2.xlsm

تم تعديل فبراير 23, 2023 بواسطه Mohamed Hicham

[ابو هاله النبلسي]

أحسنتم اساتذه كان جوابكم شافي وكافي 

3 ساعات مضت, lionheart said:

Try this code

Const numRows As Long = 100

Sub Test()
    Dim dataArray(), subArrays(), sheetNames() As String, ws As Worksheet, srcSheet As Worksheet, newSheet As Worksheet, dataRange As Range, sheetName As String, lr As Long, i As Long, j As Long, k As Long, cnt As Long, startRow As Long, endRow As Long
    Application.ScreenUpdating = False
        For Each ws In ThisWorkbook.Worksheets
            If Left(ws.Name, 1) = "T" And IsNumeric(Right(ws.Name, Len(ws.Name) - 1)) Then
                Application.DisplayAlerts = False
                    ws.Delete
                Application.DisplayAlerts = True
            End If
        Next ws
        Set srcSheet = ThisWorkbook.Worksheets(1)
        lr = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
        Set dataRange = srcSheet.Range("A2:D" & lr)
        dataArray = dataRange.Value
        subArrays = SplitArray(dataArray)
        cnt = 1
        ReDim sheetNames(1 To UBound(subArrays))
        For i = 1 To UBound(subArrays)
            Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            With newSheet
                .DisplayRightToLeft = True
                sheetName = "T" & cnt
                .Name = sheetName
                sheetNames(i) = sheetName
                srcSheet.Rows(1).Copy Destination:=.Rows(1)
                startRow = (i - 1) * numRows + 1
                endRow = WorksheetFunction.Min(i * numRows, UBound(subArrays(i)))
                For j = 1 To UBound(subArrays(i), 1)
                    For k = 1 To UBound(subArrays(i), 2)
                        .Cells(j + 1, k).Value = subArrays(i)(j, k)
                    Next k
                Next j
                cnt = cnt + 1
                .Range("A1").CurrentRegion.Columns.AutoFit
            End With
        Next i
    Application.ScreenUpdating = True
End Sub

Public Function SplitArray(ByVal arr)
    Dim numRecords As Long, numArrays As Long, i As Long, j As Long, ii As Long, startRow As Long, endRow As Long
    numRecords = UBound(arr, 1)
    numArrays = WorksheetFunction.Ceiling(numRecords / numRows, 1)
    ReDim subArrays(1 To numArrays)
    For i = 1 To numArrays
        startRow = (i - 1) * numRows + 1
        endRow = WorksheetFunction.Min(i * numRows, numRecords)
        ReDim subArray(1 To endRow - startRow + 1, 1 To UBound(arr, 2))
        For j = startRow To endRow
            For ii = LBound(arr, 2) To UBound(arr, 2)
                subArray(j - startRow + 1, ii) = arr(j, ii)
            Next ii
        Next j
        subArrays(i) = subArray
    Next i
    SplitArray = subArrays
End Function

 

thank you dear so thanks dear

[محمد هشام.]

العفو اخي لاكن لكل حق حقه المفروض أفضل إجابة تكون لصاحب الكود الأستاذ  @lionheart أنا فقط قمت بتعديل بسيط جدا  ليتناسب مع طلبك الأخير 

[ابو هاله النبلسي]

13 دقائق مضت, Mohamed Hicham said:

العفو اخي لاكن لكل حق حقه المفروض أفضل إجابة تكون لصاحب الكود الأستاذ  @lionheart أنا فقط قمت بتعديل بسيط جدا  ليتناسب مع طلبك الأخير 

عجبني تواضعك ياراقي