For Next ile 100 kere döngü

[cems]

A sutununda ; A1 Şirket sıra NO
A2 Şirket kod kısa adı
A3 Şirket tam açık ünvanı bulunmakta ve bunların B1, C1 , D1 olarak transpoze edilerek yanyana yazılması gerekli .

Makro kaydet ve daha sonra kopyala yapıştır ile

Range("A4:A6").Select
Selection.Copy
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Range("A7:A9").Select
Selection.Copy
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Range("A10:A12").Select
Selection.Copy
Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Yapmakla birlikte bu şekilde 100 kere yapmak yerine For Next döngüsü ile 1 kerede yapmak için , ilk kod üzerinde nasıl bir düzeltme yapmamı ve tek tuş çalıştırarak aşağı doğru olan listeyi soldan sağa transpoze edilmiş olarak yazdırabilirim ?

 

[YUSUF44]

Aşağıdaki kod A sütunundaki tüm verileri belirttiğiniz gibi B, C, D sütunlarına aktarır:

Sub aktar()
son = Cells(Rows.Count, "A").End(3).Row
For i = 4 To son Step 3
Cells(i, "B") = Cells(i, "A")
Cells(i, "C") = Cells(i + 1, "A")
Cells(i, "D") = Cells(i + 2, "A")
Next
End Sub

 

[cems]

Sayın YUSUF44

Oldukça hızlı bir şekilde çalıştı , çok teşekkür ederim