セルをコピーして乗算し、各セルを下に貼り付けます。

Question

90セルをコピーして、各セルを別の列にコピーする必要があります。コピーされたすべてのセルは、互いに同一の52個のセルになる必要があり、すべてのセルはブランクなしで作成する必要があります。したがって、私は4680セルで終わるはずですが、コードは機能しません。

誰でも手助けできますか？

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

あなたのコードを見ることで私には分かりませんでしたが、私が正しく理解しているかどうかはわかりません。しかし、多分あなたはこのような何かを探してきました：

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