如何在vba中添加帶計數器的循環

Question

我在名為Sheet1的Excel工作表中有一列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歲

我編寫了以下代碼來復制前兩個ID。 我可以繼續復制粘貼代碼的后半部分，只需更改單元格，但是，我有100個ID。 這將花費太長時間。 我想每當一個過程重復時，我應該使用一個循環。 你能幫我把這個重復的代碼變成一個循環嗎？

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

它一次一個地遍歷工作表中的每一行，將最后一列中的名稱和關聯數字復制到該行中的值。 應該非常快速地工作，不需要不斷復制和粘貼。

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