宏，使用數組將工作表複製到不同的工作簿

Question

我們有一個SSRS報表，每個部門都有單獨的工作表。我們運行一個宏，用分部名稱重命名所有工作表，然後將特定工作表複製到新工作簿中，以通過電子郵件發送給部門。代碼的問題在於，如果其中一個部門在當月沒有工作表，則宏錯誤會顯示「不在指定範圍內」的錯誤。有沒有辦法告訴它忽略丟失的工作表，如果他們這次不存在？這裏是代碼：

Sheets(Array("AB", "CD", "EF", "GH", "IJ", "KL")).Copy 
Sheets("AB").Select 
ActiveWorkbook.SaveAs Filename:= _ 
    Path & "Holder Agings " & Today & ".xlsx", FileFormat:=xlOpenXMLWorkbook, _ 
    Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ 
    CreateBackup:=False 

謝謝！

Answer 1

我同意Rusan Kax，沒有完整的代碼塊，很難準確地生成你需要的代碼。下面的代碼顯示了兩種技術。你應該能夠適應你的要求之一。

Option Explicit 
Sub Test1() 

    ' Demonstrate CheckWshts(Array) which removes names from the array 
    ' if they do not match the name of a worksheet within the active 
    ' workbook 

    Dim InxWsht As Long 
    Dim WshtTgt() As Variant 

    WshtTgt = Array("AB", "CD", "EF", "GH", "IJ", "KL") 
    Call CheckWshts(WshtTgt) 

    For InxWsht = LBound(WshtTgt) To UBound(WshtTgt) 
    Debug.Print WshtTgt(InxWsht) 
    Next 

End Sub 
Sub Test2() 

    ' Demonstrates WorksheetExists(Name) which returns True 
    ' if worksheet Name is present within the active workbook. 

    Dim InxWsht As Long 
    Dim WshtTgt() As Variant 

    WshtTgt = Array("AB", "CD", "EF", "GH", "IJ", "KL") 

    For InxWsht = LBound(WshtTgt) To UBound(WshtTgt) 
    If WorksheetExists(CStr(WshtTgt(InxWsht))) Then 
     Debug.Print WshtTgt(InxWsht) & " exists" 
    Else 
     Debug.Print WshtTgt(InxWsht) & " does not exist" 
    End If 
    Next 

End Sub 
Sub CheckWshts(WshtTgt() As Variant) 

    ' * WshtTgt is an array of worksheet names 
    ' * If any name is not present in the active workbook, 
    ' remove it from the array 

    Dim Found As Boolean 
    Dim InxWshtActCrnt As Long 
    Dim InxWshtTgtCrnt As Long 
    Dim InxWshtTgtMax As Long 

    InxWshtTgtCrnt = LBound(WshtTgt) 
    InxWshtTgtMax = UBound(WshtTgt) 

    Do While InxWshtTgtCrnt <= InxWshtTgtMax 
    Found = False 
    For InxWshtActCrnt = 1 To Worksheets.Count 
     If Worksheets(InxWshtActCrnt).Name = WshtTgt(InxWshtTgtCrnt) Then 
     Found = True 
     Exit For 
     End If 
    Next 
    If Found Then 
     ' Worksheet WshtTgt(InxWshtTgtCrnt) exists 
     InxWshtTgtCrnt = InxWshtTgtCrnt + 1 
    Else 
     ' Worksheet WshtTgt(InxWshtTgtCrnt) does not exist 
     WshtTgt(InxWshtTgtCrnt) = WshtTgt(InxWshtTgtMax) 
     InxWshtTgtMax = InxWshtTgtMax - 1 
    End If 
    Loop 

    ' Warning this code does not handle the situation 
    ' of none of the worksheets existing 

    ReDim Preserve WshtTgt(LBound(WshtTgt) To InxWshtTgtMax) 

End Sub 
Function WorksheetExists(WshtName As String) 

    ' Returns True is WshtName is the name of a 
    ' worksheet within the active workbook. 

    Dim InxWshtCrnt As Long 

    For InxWshtCrnt = 1 To Worksheets.Count 
     If Worksheets(InxWshtCrnt).Name = WshtName Then 
     WorksheetExists = True 
     Exit Function 
     End If 
    Next 

    WorksheetExists = False 

End Function 

Answer 2

因爲Worksheets收集不提供，這將使我們檢查，如果特定的表名代表我們通過所有工作表的名稱進行迭代，並得到項目從集合中有效表的任何方法。這裏的例子是On Error Resume Next，如果特定名稱不代表現有工作表，它將忽略錯誤。這樣allNames陣列被過濾，無效名稱不會被添加到僅包含有效名稱的新陣列names。

Public Sub test() 
    Dim allNames As Variant 
    Dim names As Variant 
    Dim name As Variant 
    Dim someSheet As Worksheet 

    allNames = Array("AB", "CD", "EF", "GH", "IJ", "KL") 

    On Error Resume Next 

    For Each name In allNames 
     Err.Number = 0 
     Set someSheet = Worksheets(name) 
     If Err.Number <> 0 Then _ 
      GoTo continue 

     If IsArray(names) Then 
      ReDim Preserve names(UBound(names) + 1) 
     Else 
      ReDim names(0 To 0) 
     End If 

     names(UBound(names)) = name 
continue: 
    Next name 

    On Error GoTo 0 

    If Not IsArray(names) Then _ 
     Exit Sub 

    Sheets(names).Copy 
    ' your code ... 
End Sub