VBA将工作表拆分为2个不同的工作簿
我有一个包含30多个工作表的工作簿，每个标签都标有“-A”或“-G”。 我正试图保存以-A结尾的单个工作簿中的选项卡名称和-G在不同的工作簿中。 我想将工作表移动到新的工作簿，因为我使用第一个作为主文件。 此外，有时可能会有所有-A和没有-G等等。
我仍在编写下面的代码。 我将不胜感激任何帮助！ 谢谢！
Sub MoveSheets() Dim ws As Worksheet, ss As Worksheet, FolderName As String, Wb1 As Workbook, Wb2 As Workbook Application.ScreenUpdating = False FolderName = ThisWorkbook.Path DateString = Format(Now, "mm-dd-yy hh-mm") For Each ws In ThisWorkbook.Worksheets If Right(ws.Name, 3) = "-A" Then ws.Move After:=ss End If Set ss = ActiveSheet Next ws ThisWorkbook.Activate Wb.SaveAs FolderName _ & "\" & "AFILE" & " " & DateString For Each ws In ThisWorkbook.Worksheets If Right(ws.Name, 3) = "-G" Then ws.Move After:=ss End If Set ss = ActiveSheet Next ws ThisWorkbook.Activate Wb.SaveAs FolderName _ & "\" & "GFILE" & " " & DateString Application.ScreenUpdating = True 结束小组
你去了，我知道它可以缩短，是重复的，但它应该完成工作！
让我知道这是否适合你。
已更新（浏览添加的文件夹）：
Sub MoveSheets() With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = ActiveWorkbook.Path & "\" .Show If .SelectedItems.Count = 0 Then Exit Sub fdlr = .SelectedItems(1) End With Dim oXLApp As Object, wb As Object, wb2 As Object, ws As Object Dim TempFile1 As String, TempFile2 As String Dim CountA As Long, CountG As Long TempFile1 = Environ$("temp") & "/" & "1" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsm" TempFile2 = Environ$("temp") & "/" & "2" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsm" On Error Resume Next Kill TempFile1 Kill TempFile2 On Error GoTo 0 ThisWorkbook.SaveCopyAs TempFile1 ThisWorkbook.SaveCopyAs TempFile2 'save AFILE Set oXLApp = CreateObject("Excel.Application") Set wb = oXLApp.Workbooks.Open(TempFile1) oXLApp.DisplayAlerts = False For Each ws In wb.Worksheets ws.Visible = True Next CountA = 0 For Each ws In wb.Worksheets If Right(ws.Name, 2) = "-A" Then CountA = CountA + 1 Next If Not CountA = 0 Then For Each ws In wb.Worksheets If Not Right(ws.Name, 2) = "-A" Then ws.Delete Next 'you can change the "FileFormat" in the below line to xlOpenXMLWorkbookMacroEnabled 'as well as change the extension to ".xlsm" in case you want to retain macro in your saved files wb.SaveAs Filename:=fdlr & "\" & "AFILE" & " " & Format(Now, "mm-dd-yy hh-mm") & ".xlsx", FileFormat:=xlOpenXMLWorkbook Set wb2 = oXLApp.ActiveWorkbook wb2.Close (False) End If oXLApp.DisplayAlerts = True On Error Resume Next Kill TempFile1 On Error GoTo 0 oXLApp.Quit Set oXLApp = Nothing Set wb = Nothing Set wb2 = Nothing Set ws = Nothing 'save GFILE Set oXLApp = CreateObject("Excel.Application") Set wb = oXLApp.Workbooks.Open(TempFile2) oXLApp.DisplayAlerts = False For Each ws In wb.Worksheets ws.Visible = True Next CountG = 0 For Each ws In wb.Worksheets If Right(ws.Name, 2) = "-G" Then CountG = CountG + 1 Next If Not CountG = 0 Then For Each ws In wb.Worksheets If Not Right(ws.Name, 2) = "-G" Then ws.Delete Next 'you can change the "FileFormat" in the below line to xlOpenXMLWorkbookMacroEnabled 'as well as change the extension to ".xlsm" in case you want to retain macro in your saved files wb.SaveAs Filename:=fdlr & "\" & "GFILE" & " " & Format(Now, "mm-dd-yy hh-mm") & ".xlsx", FileFormat:=xlOpenXMLWorkbook Set wb2 = oXLApp.ActiveWorkbook wb2.Close (False) End If oXLApp.DisplayAlerts = True On Error Resume Next Kill TempFile2 On Error GoTo 0 oXLApp.Quit Set oXLApp = Nothing Set wb = Nothing Set wb2 = Nothing Set ws = Nothing Application.DisplayAlerts = False For Each ws In ThisWorkbook.Worksheets If Right(ws.Name, 2) = "-A" Or Right(ws.Name, 2) = "-G" Then ws.Delete Next Application.DisplayAlerts = True End Sub