如何在Excel VBA中循环播放宏

Arco Jansen 发表于 Dev

阿科·詹森

我想在Excel VBA中循环某个宏。但是，我不知道该怎么做（我多次尝试并失败了）。下面的代码中的注释用于显示我想做什么。这样的代码可以完美地工作，我只希望它为每个数据块循环，直到所有数据都已转置到第二个工作表中为止（第一个工作表包含大约5000行数据，每18行必须转置为1个数据行）第二个工作表中的行）：

    Sub test()

' test Macro

Range("G2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]/RC[-1]*100"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G19"), Type:=xlFillDefault
Range("G2:G19").Select
Range("A2:C2").Select
Selection.Copy
Sheets("Sheet2_Transposed data").Select
Range("A2").Select
ActiveSheet.Paste
    'I want to loop this for every next row until all data has been pasted (so A3, A4, etc.)
Sheets("Sheet1_session_data").Select
Range("G2:G19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2_Transposed_data").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=True
Range("D2:U2").Select
Application.CutCopyMode = False
    'Here I also want to loop for every next row until all data has been transposed and pasted (e.g. D3:U3, D4:U4 etc.)
Selection.NumberFormat = "0"
Sheets("Sheet1_session_data").Select
Rows("2:19").Select
Selection.Delete Shift:=xlUp
    ' Here I delete the entire data chunck that has been transposed, so the next chunck of data is the same selection. 

End Sub

希望这个问题是可以理解的，希望有人能提供帮助。谢谢。

悉达思·劳特

您实际上可以减少代码。

首先提示：

请避免使用.Select/.Activate INTERESTING READ

第二个提示：

您可以一次性在相关单元格中输入公式，而不必执行自动填充。例如。这个

Range("G2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]/RC[-1]*100"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G19"), Type:=xlFillDefault

可以写成

Range("G2:G19").FormulaR1C1 = "=RC[-2]/RC[-1]*100"

第三提示：

您无需复制并粘贴在单独的行中。您可以一行完成。例如

Range("A2:C2").Select
Selection.Copy
Sheets("Sheet2_Transposed data").Select
Range("A2").Select
ActiveSheet.Paste

可以写成

Range("A2:C2").Copy Sheets("Sheet2_Transposed data").Range("A2")

做PasteSpecial时也是一样。但是你.Value = .Value这样

Range("G2:G19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1_Transposed_data").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

可以写成

Sheets("Sheet1_Transposed_data").Range("D2:D19").Value = _
Sheets("Sheet1").Range("G2:G19").Value

错过了Transpose部分。（感谢Simoco）。在这种情况下，您可以将代码编写为

Range("A2:C2").Copy 
Sheets("Sheet2_Transposed data").Range("D2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True

第四条提示：

要遍历单元格，可以使用For Loop。假设您要遍历单元格A2，A20则可以这样做

For i = 2 To 20
    With Range("A" & i)
        '
        '~~> Do Something
        '
    End With
Next i

编辑：

您之前和之后的截图（来自评论）：

在此处输入图片说明

和

在此处输入图片说明

看完屏幕截图后，我想这就是您要尝试的？正如我刚刚写的那样，这未经测试。让我知道您是否遇到任何错误:)

Sub test()
    Dim wsInPut As Worksheet, wsOutput As Worksheet
    Dim lRow As Long, NewRw As Long, i As Long

    '~~> Set your sheets here
    Set wsInPut = ThisWorkbook.Sheets("Sheet1_session_data")
    Set wsOutput = ThisWorkbook.Sheets("Sheet2_Transposed data")

    '~~> Start row in "Sheet2_Transposed data"
    NewRw = 2

    With wsInPut
        '~~> Find Last Row
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Calculate the average in one go
        .Range("G2:G" & lRow).FormulaR1C1 = "=RC[-2]/RC[-1]*100"

        '~~> Loop through the rows
        For i = 2 To lRow Step 18
            wsOutput.Range("A" & NewRw).Value = .Range("A" & i).Value
            wsOutput.Range("B" & NewRw).Value = .Range("B" & i).Value
            wsOutput.Range("C" & NewRw).Value = .Range("C" & i).Value

            .Range("G" & i & ":G" & (i + 17)).Copy

            wsOutput.Range("D" & NewRw).PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=True

            NewRw = NewRw + 1
        Next i

        wsOutput.Range("D2:U" & (NewRw - 1)).NumberFormat = "0"
    End With
End Sub