değişken sayıda olan verileri diğer sayfaya aktarma

[Orion1]

Sayın kadr,dosyanız hazır.Ekli dosyayı inceleyiniz.

Sub tanım()
Dim hucre As Range, i As Byte, k As Byte, sat As Byte
Sheets("tanım").Select
Range("A4:A8,B4:B8,C4:F12,A14:F22,A24:D30,E28:F30,A10:A12,B10:B12").ClearContents
Set s1 = Sheets("ekle")
sat = 4
For k = 1 To 2
    For i = 2 To 4
        If s1.Cells(i, k).Value <> "" Then
            If k = 1 Then
                Cells(sat, "A").Value = s1.Cells(i, k).Value & "H"
                Else
                Cells(sat, "A").Value = s1.Cells(i, k).Value & "R"
            End If
            sat = sat + 1
        End If
    Next i
Next k
k = 1: sat = 10: sut = 1
For i = 6 To 10
    If i = 9 Then sat = 10: sut = 2
    Cells(sat, sut).Value = s1.Cells(i, "A").Value
    sat = sat + 1
Next i
sat = 4
For i = 6 To 10
    Cells(sat, "B").Value = s1.Cells(i, "B").Value
    sat = sat + 1
Next i
For Each hucre In s1.Range("C2:F10")
    Cells(hucre.Row + 2, hucre.Column).Value = hucre.Value
Next
For Each hucre In s1.Range("A12:F20")
    Cells(hucre.Row + 2, hucre.Column).Value = hucre.Value
Next
For Each hucre In s1.Range("A22:D27")
    Cells(hucre.Row + 2, hucre.Column).Value = hucre.Value
Next
Set s1 = Nothing
MsgBox "Aktarma İşlemi Tamamlandı..!!", vbOKOnly + vbInformation, "AKTARMA"
End Sub