vba birleştirme ve ıd atama

[bkk]

Merhabalar, bir vba birleştirme ve ıd atama sorum olacak;
Her sekmede yandaki gibi sayfalarım var bu sayfaların hepsini veri sayfasında ilgili sütuna yapıştırarak toplayıp, örneğin a1d grubundaki bulunan veriye aşama sıra no vermeli her 10 veri bir aşama ediyor, her grupta yeniden birden başlamalı ve bu aşamaların benzersiz aşama ıd'leri olması gerekiyor. Birde genel olarak tüm veri içinde benzersiz ıd leri olması gerekiyor, yardımcı olabilir misiniz, teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Concatenate_Data()
    Dim WS As Worksheet, S1 As Worksheet, My_Data As Variant
    Dim Say As Long, Asama As Long, Asama_No As Long
    Dim Id_No As Long, X As Long, Y As Long, Zaman As Double
  
    Application.ScreenUpdating = False
  
    Zaman = Timer
  
    Set S1 = Sheets("VERİ")
    S1.Range("B2:B" & S1.Rows.Count).ClearContents
    S1.Range("E2:G" & S1.Rows.Count).ClearContents
    S1.Range("I2:I" & S1.Rows.Count).ClearContents
    S1.Range("M:Q").Clear
  
    ReDim My_List(1 To Rows.Count, 1 To 5)
  
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> S1.Name And WS.Name <> "PROBLEM" Then
            My_Data = WS.Range("A1").CurrentRegion
            For X = 2 To UBound(My_Data, 1) Step 10
                Asama = Asama + 1
                Asama_No = 0
                For Y = X To X + 9
                    If Y > UBound(My_Data, 1) Then Exit For
                    Say = Say + 1
                    Asama_No = Asama_No + 1
                    Id_No = Id_No + 1
                    My_List(Say, 1) = My_Data(Y, 1)
                    My_List(Say, 2) = My_Data(Y, 2)
                    My_List(Say, 3) = Asama
                    My_List(Say, 4) = WS.Name & Format(Asama_No, "_00")
                    My_List(Say, 5) = WS.Name & Format(Asama, "_00") & Format(Id_No, "_0000")
                Next
            Next
        End If
    Next

    With S1
        .Range("M2").Resize(Say, 5) = My_List
        .Range("B2").Resize(Say).Value = .Range("M2").Resize(Say).Value
        .Range("E2").Resize(Say, 3).Value = .Range("N2").Resize(Say, 3).Value
        .Range("I2").Resize(Say).Value = .Range("Q2").Resize(Say).Value
        .Range("M:Q").Clear
        .Columns.AutoFit
    End With

    Erase My_List
    Set S1 = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[bkk]

Çok teşekkür ederim, uygulayıp dönüş sağlayacağım