다른 워크 시트 이름을 가진 루프 코드

Question

코드 아래에서 실행 중입니다. "fast"라는 워크 시트에는 cycle, run, walk, jog 등의 이름이 포함되어 있습니다. 코드는 현재 특정 행에서 "cycle"이라는 단어를 검색하고 발견 된 경우 전체 열을 복사 한 후 " 주기". 지금은 스크립트를 반복하고 "실행" "걷기"와 같은 이름에 대해 "주기"를 변경합니다. 단순히 동일한 스크립트를 반복해서 반복하지 않음으로써 더 짧고 효율적으로 만들 수 있습니까?

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