Макросы, используя массив для копирования рабочих листов в другую книгу

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

Я согласен с Русаном Каксом, без полного кода кода сложно точно составить код, который вам нужен. В приведенном ниже коде показаны два метода. Вы должны уметь адаптировать один из них к своим требованиям.

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