如何使用VBA在excel文件中拆分工作表，每个新工作表都有一个额外的下拉列表选项卡

Question

Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

我使用的VBA代码将每个工作表拆分为单独的文件(见上文(，但问题是原始文件中的所有工作表都依赖于一个具有下拉列表值的工作表。(例如，如果工作表是：星期一、星期二、星期三、星期四、星期五，下拉列表(，那么通过使用下面的vba代码，星期一到星期五工作表的下拉列表不起作用。如何更改此代码，以便每个工作表都带有下拉工作表/选项卡的副本？或者有其他解决方案可以让我在每个选项卡中保留下拉列表值，并能够拆分文件？

这段代码只单独分隔每个工作表，但我需要用原始文件中的下拉列表选项卡的副本来分割文件中的每个工作表

Answer 1

导出具有其他相同工作表的工作表

Option Explicit
Sub ExportWorksheets()

Const CopyWithAll As String = "DropDown Lists"

Dim DoNotCopy() As Variant: DoNotCopy = Array(CopyWithAll) ' add more!?

Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim FolderPath As String: FolderPath = wb.Path & Application.PathSeparator

Application.ScreenUpdating = False

Dim ws As Worksheet
Dim wsName As String

For Each ws In wb.Worksheets
wsName = ws.Name
If IsError(Application.Match(wsName, DoNotCopy, 0)) Then
wb.Worksheets(Array(wsName, CopyWithAll)).Copy
With Workbooks(Workbooks.Count)
Application.DisplayAlerts = False ' overwrite, no confirmation
.SaveAs FolderPath & wsName
Application.DisplayAlerts = True
.Close False
End With
End If
Next ws

Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation
End Sub