使用数组复制所有工作表

Question

我在网上研究了我的查询，但找不到完全匹配的解决方案。这可能很简单，但我还没有找到一个密切相关的答案可以帮助我专门解决这个问题。

如何使用数组函数复制工作簿中的所有工作表？我正在尝试使用下面的开源代码sn-p：

'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Sheet1", "Sheet3")).Copy
    End With

这里提到了特定的工作表名称（“Sheet1”、“Sheet3”）。我正在尝试复制活动工作簿中的所有工作表，而不是特定工作簿。可以将对所有工作表的引用（例如表示所有工作表的一个对象）插入参数列表中，还是数组仅适用于对多个工作表的引用？ 感谢您的帮助。

Answer 1

只需将所有工作表名称放入数组中即可。

Sub test()
    Dim Wb As Workbook, Ws As Worksheet
    Dim toWb As Workbook
    Dim vName()
    Dim i As Integer
    
    Set Wb = ActiveWorkbook
    Set toWb = Workbooks(2)
    
    For Each Ws In Wb.Worksheets
        n = n + 1
        ReDim Preserve vName(1 To n)
        vName(n) = Ws.Name
    Next Ws
    Wb.Sheets(vName).Copy After:=toWb.Sheets(toWb.Sheets.Count)
    
End Sub

Answer 2

（工作）工作表名称到数组

除了.Sheets(Array("Sheet1", "Sheet3")).Copy，使用“代码”下的函数，您可以使用以下方法之一：

• 当您只想复制工作表时：

  .Sheets(getWorksheetNames(Sourcewb)).Copy
  

• 当您想要包含其他工作表类型（如图表、宏工作表或对话框）时：

  .Sheets(getSheetNames(Sourcewb)).Copy
  

如果您确定Sourcewb '不是什么都不是' 并且对于getWorksheetNames，工作簿中至少有一个工作表。

守则

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes all worksheet names to a 1D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getWorksheetNames(Book As Workbook) _
         As Variant
    
    If Book Is Nothing Then
        GoTo ProcExit
    End If
    
    If Book.Worksheets.Count = 0 Then
        GoTo ProcExit
    End If

    Dim Data As Variant
    ReDim Data(1 To Book.Worksheets.Count)
    
    Dim ws As Worksheet
    Dim n As Long
    
    For Each ws In Book.Worksheets
        n = n + 1
        Data(n) = ws.Name
    Next ws
    
    getWorksheetNames = Data

ProcExit:
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes all sheet names to a 1D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getSheetNames(Book As Workbook) _
         As Variant
    
    If Book Is Nothing Then
        GoTo ProcExit
    End If
    
    Dim Data As Variant
    ReDim Data(1 To Book.Sheets.Count)
    
    Dim sh As Object
    Dim n As Long
    
    For Each sh In Book.Sheets
        n = n + 1
        Data(n) = sh.Name
    Next sh
    
    getSheetNames = Data

ProcExit:
End Function

Sub testGetNames()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim Data As Variant
    Dim ResultString As String
    
    Data = getWorksheetNames(wb)
    ResultString = Join(Data, vbLf)
    Debug.Print "Worksheet Names List" & vbLf & ResultString
    
    Data = getSheetNames(wb)
    ResultString = Join(Data, vbLf)
    Debug.Print "Sheet Names List" & vbLf & ResultString

End Sub