Hücreleri kopyalayın ve bunları çoğaltın, ardından her bir hücrenin altını yapıştırın

Question

90 hücreyi kopyalamak istiyorum ve her bir hücrenin başka bir sütuna kopyalanması gerekiyor. Kopyalanan her hücrenin, birbirinin altında 52 özdeş hücre olması gerekir ve tüm hücreler herhangi bir boşluk olmadan yaratılmalıdır. Bu nedenle, 4680 hücresi ile sonuçlanmalı, ancak kod çalışmıyor.

Herkes yardımcı olabilir mi?

Sub Copy_bud() 
Dim WB As Workbook 
Dim WS As Worksheet 
Dim i, j As Long 
Dim kopi As Boolean 

Set WB = ThisWorkbook 
Set WS = WB.Worksheets("Ark1") 

n = WS.Cells(1, 1).CurrentRegion.Rows.Count 
j = 1 

For i = 1 To n 
    While kopi = True 
     WS.Cells(i, 1).Select 
     Selection.copy 
     WS.Cells(j, 5).Paste 
     j = j + 51 
    Wend 
    Next i 
End Sub 

Answer 1

Kodunuza bakarak bana açık olmadığı için doğru anlaşıldığından emin değilim. Ama belki böyle bir şey arıyordum:

Option Explicit 

Sub Copy_bud() 

Dim WB As Workbook 
Dim WS As Worksheet 

Dim lngRow As Long 
Dim lngLastRow As Long 

Set WB = ThisWorkbook 
Set WS = WB.Worksheets("Ark1") 

lngLastRow = WS.Cells(1, 1).CurrentRegion.Rows.Count 
For lngRow = 1 To lngLastRow 
    WS.Range(WS.Cells(1, 4 + lngRow), WS.Cells(lngLastRow, 4 + lngRow)).Value2 = WS.Cells(lngRow, 1).Value2 
Next lngRow 

End Sub