使用阵列复制所有工作表

Question

我已经在线研究了我的查询，但找不到完全匹配的解决方案。这可能很简单，但我还没有找到一个密切相关的答案来帮助我具体解决这个问题。

如何使用arrays函数复制工作簿中的所有工作表？我正在尝试使用以下开源代码片段：

'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

(工作(工作表名称到数组

使用">the Code"下的函数，您可以使用以下函数之一来代替.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