異なるワークシート名のループコード

Question

以下のコードを実行しています。 「高速」という名前のワークシートには、サイクル、実行、ウォーク、ジョグなどの名前が含まれています。コードは現在、特定の行の単語「サイクル」を検索し、見つかった場合は列全体をコピーし、サイクル"。現時点では、スクリプトを繰り返して「実行」「散歩」などの名前を「サイクル」に変更しています。同じスクリプトを何度も繰り返して繰り返すだけではなく、これを短く効率的にすることができます。

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