Excelでネストループをコピーして貼り付けます

Question

シート1に8列（AH）をループして、シート2に新しい列を1つ作成します。大量のデータのためにこれを行う必要があり、これを行うための最善の方法だと思う、それここ

である私のコード

Range("E5").Select 
Range(Selection, Selection.End(xlDown)).Select 
Range("E5").Select 
Range(Selection, Selection.End(xlDown)).Select 
ActiveWindow.SmallScroll Down:=-96 
Range("E5:E110").Select 
Selection.Copy 
Sheets("56 J").Select 
Range("A2").Select 
ActiveSheet.Paste 
Sheets("56 g").Select 

Range("F5").Select 
Range(Selection, Selection.End(xlDown)).Select 
Range("F5").Select 
Range(Selection, Selection.End(xlDown)).Select 
ActiveWindow.SmallScroll Down:=-96 
Range("F5:F110").Select 
Selection.Copy 
Sheets("56 J").Select 
Range("A110").Select 
ActiveSheet.Paste 
Sheets("56 g").Select 

私は列をループ何かでこれを置くことができますどのように任意のアイデア？

これはまた、ループしたときの時間と文字が対応するデータに滞在したいと思い、私はdo.Iしようとしているものの一例です。しかし、今私の主な焦点は、データを単一の列にまとめることです。

Answer 1

ソースと目的地の列は、数学的にループする必要があります。

Dim c As Long, n As Long, tws As Worksheet 

Set tws = Worksheets("56 j") 

With Worksheets("56 g") 
    For n = 1 To 2 
     For c = 1 To 8 
      With .Range(.Cells(5, c + (n - 1) * 8), .Cells(.Rows.Count, c + (n - 1) * 8).End(xlUp)) 
       tws.Cells(tws.Rows.Count, n).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value 
      End With 
     Next c 
    Next n 
End With 

Answer 2

Option Explicit 
Sub copydata() 
Dim WS1, WS2 As Worksheet 
Dim lastrow As Long 
Dim ws1Row, ws2Row As Long 
Dim mycol As Integer 

Set WS1 = Worksheets("sheet1") 
Set WS2 = Worksheets("sheet2") 
lastrow = WS1.Cells(WS1.Rows.Count, "A").End(xlUp).Row 
ws2Row = 2 
For ws1Row = 5 To lastrow 
    For mycol = 1 To 8 
     WS2.Cells(ws2Row, 1) = WS1.Cells(ws1Row, mycol) 
     WS2.Cells(ws2Row, 2) = WS1.Cells(ws1Row, mycol + 8) 
     ws2Row = ws2Row + 1 
    Next mycol 
Next ws1Row 
End Sub