在一个 Excel 工作簿中拆分具有相同名称范围的工作表 - Excel VBA
Posted
技术标签:
【中文标题】在一个 Excel 工作簿中拆分具有相同名称范围的工作表 - Excel VBA【英文标题】:Splitting Sheets with Same Name Range in One Excel Workbook - Excel VBA 【发布时间】:2021-12-30 21:18:45 【问题描述】:我有一些包含 100 多张工作表的 Excel 工作簿。工作表名称如下所示;
TTBMA2453_Speclist、TTBMA2454_Speclist、TTBMA2455_Speclist 等等…… WBXXTTBMA2453_Featurelist、WBXXTTBMA2454_Featurelist、WBXXTTBMA2455_Featurelist 等等…… WBXXTTBMA2453_Corelist、WBXXTTBMA2454_Corelist、WBXXTTBMA2455_Corelist 等等……我想在同一工作簿中拆分以相同规格列表名称开头的所有规格、功能和核心列表工作表,并使用 Excel VBA 合并/保存到特定文件中的另一个 Excel 工作簿。
(例如,结合 TTBMA2453_Speclist、WBXXTTBMA2453_Featurelist WBXXTTBMA2453_Corelist 并将它们复制为新工作簿与原始工作表)
请找到我的代码示例。此代码将同名的工作表(我手动添加)拆分为工作簿。但是,此代码不会重新合并不同工作簿中的工作表,并且工作表名称是手动输入的。所以,这不是我想要的。
Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
For Each ws In ThisWorkbook.Worksheets
If Left$(ws.Name, 9) = "TTBMA2453" Then ' <--- added an IF statement
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
【问题讨论】:
感谢@RaymondWu 的澄清。代码已添加。 您能否澄清一下,如果所有这些工作表的名称都遵循确切的格式?[SpecName]_Speclist
、WBXX[SpecName]_Featurelist
和 WBXX[SpecName]_Corelist
? IE。如果我可以识别规范名称,可以根据该知识构建功能列表和核心列表的工作表名称吗? @优素福
正确,所有这些工作表都遵循您提到的确切格式。附:规格名称不同,例如 TTBMA2453、TTBMA2454 和 TTBMA2455....
我无法为您提供代码,因为我没有计算机,但逻辑是 1) 循环遍历工作表(您已完成),2) 检查 If Right$(ws.Name, 9) = "_Speclist" Then
, 3 ) 如果为真,则声明一个字符串变量并获取规范名称specName = Split(ws.Name, "_")(0)
,4) 将规范列表工作表复制到新工作簿ws.Copy
5) 复制其他 2 个工作表。 ThisWorkbook.Worksheets("WBXX" & specName & "_Featurelist").Copy After:=ActiveWorkbook.Worksheets(1)
,ThisWorkbook.Worksheets("WBXX" & specName & "_Corelist").Copy After:=ActiveWorkbook.Worksheets(2)
。 6)保存并关闭
显然我无法测试它,所以你可以试一试或等到有人写出经过测试的答案@Yusuf
【参考方案1】:
Option Explicit
Sub SplitEachWorksheet()
Dim wb As Workbook, wbNew As Workbook, ws As Worksheet
Dim num As Collection, n, dict As Object
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Set num = new Collection
Set dict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
If ws.Name Like "*_Speclist" Then
num.Add Left(ws.Name, Len(ws.Name) - 9)
End If
dict.Add ws.Name, ws.Index
Next
' check sheets
Dim msg As String, s As String
For Each n In num
s = "WBXX" & n & "_Corelist"
If Not dict.exists(s) Then
msg = msg & vbLf & s & " missing"
End If
s = "WBXX" & n & "_Featurelist"
If Not dict.exists(s) Then
msg = msg & vbLf & s & " missing"
End If
Next
If Len(msg) > 0 Then
MsgBox msg, vbCritical
Exit Sub
End If
' check workbooks
Application.ScreenUpdating = False
For Each n In num
wb.Sheets(n & "_Speclist").Copy
Set wbNew = ActiveWorkbook
wb.Sheets("WBXX" & n & "_Featurelist").Copy after:=wbNew.Sheets(1)
wb.Sheets("WBXX" & n & "_Corelist").Copy after:=wbNew.Sheets(2)
wbNew.SaveAs Filename:=FPath & "\" & n
wbNew.Close False
Next
Application.ScreenUpdating = True
' result
MsgBox num.Count & " worksbooks created in " & FPath, vbInformation
End Sub
【讨论】:
如果我可以建议 - 而不是Dim num As New Collection
,请使用 Dim num As Collection: Set num = New Collection
。 ***.com/questions/42656468/…以上是关于在一个 Excel 工作簿中拆分具有相同名称范围的工作表 - Excel VBA的主要内容,如果未能解决你的问题,请参考以下文章
Excel Power Query 拆分表格顶部/底部 50%