اذهب الي المحتوي
أوفيسنا

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


إذهب إلى الإجابة الإجابة بواسطة محي الدين ابو البشر,

الردود الموصى بها

قام بنشر

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

  • Like 2
  • Thanks 1
  • تمت الإجابة
قام بنشر

بالاذن من الاستاذ 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

  • Like 5

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information