具有不同工作表名称的循环代码

Question

我正在运行ning 下面的代码。名为 "fast" 的工作表包含诸如 cycle、运行、walk、jog 等名称。代码当前在特定行中搜索单词 "cycle"，如果找到，它会复制整列并将其粘贴到名为 "cycle" 的工作表中。目前，我只是重复脚本并更改 "Cycle" 等名称，例如 "run" "walk" 等。我是否可以通过不只是重复相同的脚本来使它更短、更高效和结束。

Sub Cycle()

Dim C As Range
Dim col As Long, lastCol As Long

With Worksheets("fast")
    lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
    col = 1
    For Each C In .Range(.Cells(2, 1), .Cells(2, lastCol))
        If C.value = "Cycle" Then
            C.EntireColumn.Copy Destination:=Sheets("Cycle").Columns(col)
            C.EntireColumn.Copy
            Sheets("Cycle").Columns(col).PasteSpecial xlPasteValues
            col = col + 1
        End If
    Next C
End With
Worksheets("Cycle").Activate

End Sub

Answer 1

试试下面的代码，如果这就是你的意思，请告诉我：

Option Explicit

Sub Cycle()

Dim C               As Range
Dim StringsArr      As Variant
Dim col As Long, lastCol As Long

StringsArr = Array("cycle", "run", "walk", "jog")

With Worksheets("fast")
    lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
    For Each C In .Range(.Cells(2, 1), .Cells(2, lastCol))
        ' check per cell if value is one of the values in StringsArr array
        If Not IsError(Application.Match(C.value, StringsArr, 0)) Then
            col = Sheets(C.value).Cells(2, Sheets(C.value).Columns.Count).End(xlToLeft).Column + 1 ' find first empty column in relevant sheet
            C.EntireColumn.Copy
            Sheets(C.value).Columns(col).PasteSpecial xlPasteValues
        End If
    Next C
End With

End Sub

具有不同工作表名称的循环代码

Loop code with different worksheet names

excel

vba

worksheet