vbaにカウンタを含むループを追加する方法

Question

ExcelワークシートにSheet1というID列があります。列Aの右側の列にあるIDに対応するデータがあります。行内のセルの量はさまざまです。例えば：

A、B、C、D、E、F、...

ジョン、5、10、15、20

ヤコブ、2、3

Jingleheimmer、 5、10、11

私がコピーしようとしているその次の形式で新しいワークシート、のSheet5、へのデータ：

A、B、C、D、E、F、...

ジョン、5

ジョン、10

ジョン、15

ジョン、20

ヤコブ、2

ヤコブ、3

Jingleheimmer、5

Jingleheimmer、10

Jingleheimmer、11

私は最初の2つのIDの上にコピーし、次のコードを書きました。コードの後半部分を貼り付けてコピーして、セルを変更することはできますが、IDは100個あります。これには時間がかかります。私はプロセスが繰り返されるたびにループを使用するべきだと思います。この繰り返しコードをループに変えるのを助けてくれますか？

Sub Macro5() 

Dim LastRowA As Integer 
Dim LastRowB As Integer 

''' Process of copying over first ID ''' 

'grab all data cells in B2 to the right 
With Sheets("Sheet1").Select 
Range("B2", Range("B2").End(xlToRight)).Select 
Selection.Copy 
End With 

'paste that data into the first empty cell of Column B in Sheet5 
With Sheets("Sheet5").Select 
Range("B1").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
End With 

'grab the corresponding ID in cell A2 
With Sheets("Sheet1").Select 
Range("A2").Select 
Application.CutCopyMode = False 
Selection.Copy 
End With 

'paste the corresponding ID into the first empty cell of Column A in Sheet5 
With Sheets("Sheet5").Select 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Range("A1").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
Application.CutCopyMode = False 
Selection.AutoFill Destination:=Range("A1:A" & LastRowB) 
End With 

''' Repeat that process for each row in Sheet1 ''' 

'grab all data cells in B3 to the right 
With Sheets("Sheet1").Select 
Range("B3", Range("B3").End(xlToRight)).Select 
Selection.Copy 
End With 

'paste that data into the first empty cell of Column B in Sheet5 
With Sheets("Sheet5").Select 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Range("B" & LastRowB + 1).Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
End With 

'grab the corresponding ID in cell A3 
With Sheets("Sheet1").Select 
Range("A3").Select 
Application.CutCopyMode = False 
Selection.Copy 
End With 

'paste the corresponding ID into the first empty cell of column A in Sheet5 
'and autofill down to the last populated cell in column B 
With Sheets("Sheet5").Select 
LastRowA = Cells(Rows.Count, "A").End(xlUp).Row + 1 
Range("A" & LastRowB + 1).Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
Application.CutCopyMode = False 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Selection.AutoFill Destination:=Range("A" & LastRowA & ":A" & LastRowB) 
End With 

End Sub 

Answer 1

これを試してください：

Sub test() 

Dim i As Integer 
Dim j As Integer 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim nRow As Integer 
Dim lRow As Integer 
Dim lCol As Integer 

Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet5") 
nRow = 1 

With ws1 

    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 

    For i = 1 To lRow 

     lCol = .Cells(i, .Columns.Count).End(xlToLeft).Column 

     For j = 2 To lCol 

      ws2.Cells(nRow, 1).Value = .Cells(i, 1).Value 
      ws2.Cells(nRow, 2).Value = .Cells(i, j).Value 
      nRow = nRow + 1 

     Next j 

    Next i 

End With 

End Sub 

これは、その行の値を有する最後の列を介してアップ名および関連する数字の上にコピーする、一度にシート1の各列を通ります。非常に迅速に作業する必要があり、定数コピー&貼り付けを必要としません。

Answer 2

これはあなたが探していることを行うはずです。

Sub test() 
Dim lastrow As Long, lastcol As Long 
Dim i As Integer, j as Integer, x as Integer 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 

Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet5") 

lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row 
x = 1 

With ws1 
    For i = 1 To lastrow 
     lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column 
     For j = 2 To lastcol 
      ws2.Cells(x, 1).Value = .Cells(i, 1).Value 
      ws2.Cells(x, 2).Value = .Cells(i, j).Value 
      x = x + 1 
     Next j 
    Next i 
End With 

End Sub