sırayla yazdırma

[mersilen]

Merhabalar

"rrrr" sayfasındaki verileri sayfa2 ye aktaracak kod lazım.
"rrrr" sayfasında A sütunundaki her boş sıra sayfa2 de satır kaydırma olarak kullanılacak
benzer veri grubları aynı satırda olacak
ben bir deneme yaptım ama kod hatalı oluyor ,değerlendirebilir misiniz?

Sub dene3()
Dim i, x, z, y, bul As Integer
Application.Calculation = xlManual
Application.ScreenUpdating = False
Range("a2", "az10") = Clear: Range("e19:e35") = Clear

i = 2
For x = 1 To Worksheets("rrrr").Cells(Rows.Count, "A").End(xlUp).Row

    If Worksheets("rrrr").Cells(x, 1) = "" Then
    z = Cells(Rows.Count, "A").End(xlUp).Row
    i = z + 1: GoTo atla
    End If
    
    Set bul = Range("1:1").Find(Worksheets("rrrr").Cells(x, "A").Value, LookIn:=xlValues)
    y = bul.Column
    Cells(i, y) = Worksheets("rrrr").Cells(x, "B").Value
    
atla:
Next x
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

Veya bir diğer kod, buda hatalı

Sub dene3()
Dim i, x, z, y As Integer
Dim bul As Range
Application.Calculation = xlManual
Application.ScreenUpdating = False
Range("a2", "az10") = Clear: Range("e19:e35") = Clear

i = 2

For x = 1 To Worksheets("rrrr").Cells(Rows.Count, "A").End(xlUp).Row

    If Worksheets("rrrr").Cells(x, 1) = "" Then GoTo atla Else
    
   w = Worksheets("rrrr").Cells(Rows.Count, "A").End(xlUp).Row
   t = WorksheetFunction.CountIf(Worksheets("rrrr").Cells(1, 1), Worksheets("rrrr").Cells(w, 1), "")
   İ = i + t
   
    Set bul = Range("1:1").Find(Worksheets("rrrr").Cells(x, "A").Value, LookIn:=xlValues)
    y = bul.Column
    Cells(i, y) = Worksheets("rrrr").Cells(x, "B").Value
    End If
    
atla:
Next x

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub