VBA 将工作表拆分为 2 个不同的工作簿

Question

我有一个包含 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

结束子

Answer 1

你去吧，我知道它可以缩短并且有点重复，但它应该可以完成工作！

让我知道这是否适合你。

已更新（浏览添加的文件夹）：

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