vba - 如何在vba中添加带有计数器的循环

Question

我在名为 Sheet1 的 Excel 工作表中有一列 ID。我有与 A 列右侧的列中的 ID 相对应的数据。行中的单元格数量各不相同。例如:

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

约翰、5、10、15、20

雅各布，2, 3

金格尔海默，5,10,11

我正在尝试按以下格式将该数据复制到新工作表 Sheet5 中:

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

约翰，5

约翰，10 岁

约翰，15 岁

约翰，20 岁

雅各布，2

雅各布，3

金格尔海默，5

金格尔海默，10

金格尔海默，11 岁

我编写了以下代码来复制前两个 ID。我可以继续复制粘贴代码的后半部分，只更改单元格，但是，我有数百个 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

它一次遍历工作表中的每一行，将名称和关联的数字复制到最后一列以及该行中的值。应该工作得非常快，不需要不断的复制和粘贴。