我的组织发布了 Excel 格式的每周报告，其中包含 60 多个工作表，每个工作表的标题都有一个活动缩写。目前，我手动将特定工作表复制到新工作簿中。
发现的 VBA 解决方案似乎需要数组中预定义的工作表名称。这在我的情况下不起作用，因为当没有活动时，标题为活动代码的工作表不包含在工作簿中。
我正在寻求：
我合并了在网上找到的多个代码。
在测试中，我使用了三个工作表名称。真正的运行会拉 20。标题为“BBA”和“BBB”的工作表在工作簿中，而“BBV”不在工作簿中。我愿意走不同的方向，因为我确信有一种更干净的方法。
Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
Dim MyArr, j As Long
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
Application.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
MyArr = Array("BBA", "BBV", "BBB")
For j = 0 To UBound(MyArr)
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(MyArr(j))
On Error GoTo 0
If Not ws Is Nothing Then
'Your copying code goes here
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
ws.Select
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
End If
Next
' Remove named ranges
For Each nm In ActiveWorkbook.Names
If nm.Visible Then nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "myFile.xlsm", FileFormat:=52
Application.ScreenUpdating = True
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
概念上：
此网站和其他网站上有许多代码示例，介绍如何循环工作簿中的所有工作表、如何在另一个字符串中查找字符串以及如何在工作簿之间复制工作表。
Sub ExportSheetsByActivityCodes()
Const PROC_TITLE As String = "Export Sheets By Activity Codes"
Dim dwb As Workbook ' to be closed if error
Dim WasSuccess As Boolean
On Error GoTo ClearError ' start error-handling routine
' Define constants.
Const DST_FILE_BASE_NAME As String = "New File"
' The following two constants have to be in 'sync'.
Const DST_FILE_EXTENSION As String = ".xlsm"
Const DST_FILE_FORMAT As Long = xlOpenXMLWorkbookMacroEnabled
Const DST_FILE_FILTER_LEFT As String = "Excel macro-enabled files"
Const ORDER_BY_WORKSHEET_POSITION As Boolean = False
Dim ActivityCodes() As Variant: ActivityCodes = VBA.Array( _
"BBA", "BBV", "BBB") ' add more
' Ask to proceed.
' Return the values of the array in a delimited string (for the messages).
Dim ActivityCodesList As String:
ActivityCodesList = Join(ActivityCodes, ", ")
If MsgBox("Do you want to copy the worksheets named after activity " _
& "codes """ & ActivityCodesList & """ to a new workbook?" _
& vbLf & "The worksheets in the new workbook will be without " _
& "formulas and hyperlinks, and named ranges will be removed!", _
vbYesNo + vbQuestion, PROC_TITLE) = vbNo Then GoTo ProcExit
' Return the names of the worksheets to be exported in a 1D one-based array.
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
' Define an array of the size of the number of activity codes.
Dim dwsMax As Long: dwsMax = UBound(ActivityCodes) + 1
Dim dwsNames() As Variant: ReDim dwsNames(1 To dwsMax)
Dim sws As Worksheet, dwsCount As Long, n As Long
If ORDER_BY_WORKSHEET_POSITION Then
For Each sws In swb.Worksheets
If IsNumeric(Application.Match(sws.Name, ActivityCodes, 0)) Then
dwsCount = dwsCount + 1
dwsNames(dwsCount) = sws.Name
End If
If dwsCount = dwsMax Then Exit For ' all found
Next sws
Else ' order by activity code
For n = 1 To dwsMax
On Error Resume Next ' defer error handling (sheet doesn't exist)
Set sws = swb.Worksheets(ActivityCodes(n - 1))
On Error GoTo ClearError ' restart error-handling routine
If Not sws Is Nothing Then
dwsCount = dwsCount + 1
dwsNames(dwsCount) = sws.Name
Set sws = Nothing ' reset for the next iteration
End If
Next n
End If
If dwsCount = 0 Then
MsgBox "No worksheets named after activities """ & ActivityCodesList _
& """ found!", vbExclamation, PROC_TITLE
GoTo ProcExit
End If
If dwsCount < dwsMax Then ReDim Preserve dwsNames(1 To dwsCount)
' Copy the worksheets whose names are in the array to a new workbook
' and reference this workbook.
' Note that when copying multiple sheets to a new workbook,
' the order of the sheets is always the same as their order
' in the source workbook (no matter their order in the array).
' Note that this will fail if there is no visible worksheet,
' and very hidden worksheets will not be copied.
swb.Sheets(dwsNames).Copy
Set dwb = Workbooks(Workbooks.Count)
' Process the destination workbook.
Dim dws As Worksheet, nm As Name
' Process worksheets.
For Each dws In dwb.Worksheets
With dws.UsedRange
.Hyperlinks.Delete ' delete hyperlinks
.Value = .Value ' formulas to values
Application.Goto Reference:=.Cells(1), Scroll:=True
End With
Next dws
' Process workbook.
For Each nm In dwb.Names
If nm.Visible Then nm.Delete '???
Next nm
' Move sheets to correct positions when ordering by activity code required.
If Not ORDER_BY_WORKSHEET_POSITION And dwsCount > 1 Then
For n = 1 To dwsCount
dwb.Sheets(dwsNames(n)).Move After:=dwb.Sheets(dwsCount)
Next n
End If
' Let the user choose the location and name of the destination file.
Dim dFileFilter As String:
dFileFilter = DST_FILE_FILTER_LEFT & ",*" & DST_FILE_EXTENSION
Dim dFilePath As Variant: dFilePath = Application.GetSaveAsFilename( _
InitialFileName:=swb.Path & Application.PathSeparator & _
DST_FILE_BASE_NAME, _
FileFilter:=dFileFilter, _
Title:=PROC_TITLE)
If dFilePath = False Then
MsgBox "File save canceled.", vbExclamation, PROC_TITLE
GoTo ProcExit
End If
' Prevent error if file (or file with same name) is open
' Note that the error-handling routine could cover this instead!
' Note that you cannot change the given file extension.
Dim dFileName As String: dFileName = Right(dFilePath, _
Len(dFilePath) - InStrRev(dFilePath, Application.PathSeparator))
Dim cwb As Workbook
On Error Resume Next ' defer error handling (file (workbook) exists)
Set cwb = Workbooks(dFileName)
On Error GoTo ClearError ' restart error-handling routine
If Not cwb Is Nothing Then
If StrComp(dFilePath, cwb.FullName, vbTextCompare) = 0 Then
MsgBox "The destination file """ & cwb.FullName & """ is open!", _
vbExclamation, PROC_TITLE
Else
MsgBox "Another file """ & cwb.FullName _
& """ with the same name is open!", vbExclamation, PROC_TITLE
End If
GoTo ProcExit
End If
' Save and close.
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dFilePath, FileFormat:=DST_FILE_FORMAT
Application.DisplayAlerts = False
dwb.Close SaveChanges:=False ' just got saved
Application.ScreenUpdating = True
WasSuccess = True
' Inform.
MsgBox "The following " & IIf(dwsCount <> 1, dwsCount & " ", "") _
& "sheet" & IIf(dwsCount = 1, " was", "s were") & " exported to """ _
& dFilePath & """:" & vbLf & vbLf & Join(dwsNames, vbLf), _
vbInformation, PROC_TITLE
ProcExit:
On Error Resume Next ' prevent endless loop if error in continuation
If Not WasSuccess Then
If Not dwb Is Nothing Then dwb.Close SaveChanges:=False
End If
On Error GoTo 0
Exit Sub
ClearError: ' continue error-handling routine (e.g. invalid file name)
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
& Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Sub