كل 10 ارقام في جدول

[sabah2023]

السلام عليكم

عندي شيت الارقام يحتوي علة عدة ارقام

وشيت اخر جدول 

اريد توزيع كل 10 اراقم في جدول 

وكما بين في المبلف المرفق

توزيع كل عشرة ارقام.xlsm

[lionheart]

Try this code

Sub Test()
    Const NROWS As Long = 10
    Dim a, ws As Worksheet, sh As Worksheet, r As Range, s As String, m As Long, i As Long
    With ThisWorkbook
        Set ws = .Worksheets(1): Set sh = .Worksheets(2)
    End With
    s = Join(Array(Chr(199), Chr(225), Chr(209), Chr(222), Chr(227)), Empty)
    m = 2
    Set r = sh.Columns(2)
    a = FindNext(s, r)
    If Not IsEmpty(a) Then
        For i = LBound(a) To UBound(a)
            With sh.Range("A" & a(i)).CurrentRegion.Offset(1)
                .ClearContents: .Borders.Value = 0
            End With
            sh.Range("A" & a(i) + 1).Resize(NROWS).Value = Evaluate("ROW(1:" & NROWS & ")")
            sh.Range("B" & a(i) + 1).Resize(NROWS).Value = ws.Range("A" & m).Resize(NROWS).Value
            m = m + NROWS
        Next i
    End If
End Sub

Function FindNext(ByVal strFind As String, ByVal rng As Range)
    Dim arr(), myRng As Range, iRow As Long, k As Long
    With rng
        Set myRng = .Find(What:=strFind, After:=rng.Cells(rng.Cells.Count), LookIn:=xlValues, LookAt:=xlPart)
        If Not myRng Is Nothing Then
            iRow = myRng.Row
            Do
                k = k + 1
                ReDim Preserve arr(1 To k)
                arr(k) = myRng.Row
                Set myRng = .FindNext(myRng)
            Loop Until myRng.Row = iRow
        End If
    End With
    FindNext = arr
End Function

 

Note the following

The code will find the rows that has the string `NUMBER` then to copy 10 numbers from the first worksheet and so on

But the code is limited to the headers in the second worksheet so not all the numbers in the first worksheet will be copied

[sabah2023]

وفقك الله

تسلم

 

ممكن عدم حذف التنسيقات الموجودة داخل الجدول

توزيع كل عشرة ارقام (1) - تنسيق.xlsm

تم تعديل مايو 14, 2023 بواسطه sabah2023

[محي الدين ابو البشر]

بالاذن من الاستاذ Lionheart

بنفس الطريقة 

Sub test1()
Dim a
Dim r As Range
Dim frA
Dim x&
With Sheets(1)
    a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells
End With
    x = 1
With Sheets("ÇáÌÏæá")
        Set r = Range("B:B").Find("ÇáÑÞã", , , , 1)
        frA = r.Address
            If Not r Is Nothing Then
                Do
                r.Offset(1).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "")
                x = x + 10
                 Set r = .Range("B:B").FindNext(r)
                Loop Until frA = r.Address
            End If
End With
End Sub

وخيار آخر يعتمد على عدد الاسطر وافراغات التي يجب أن تكون متساوية في كل الشيت

Sub test2()
Dim a
Dim r As Range
Dim frA
Dim x&, i&, ii&
With Sheets(1)
    a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells
End With
    x = 1
With Sheets("الجدول")
       For i = 1 To UBound(a) Step 10
               .Cells(4 + ii * 20, 2).Select
            .Cells(4 + ii * 20, 2).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "")
                x = x + 10
                ii = ii + 1
            Next
End With
End Sub

المرفق مع الخيارين

 

sabah.xlsm

[sabah2023]

جزاك الله خير