Question

我有一个包含30多个工作表的工作簿，每个选项卡都标有＆＃34; -A＆＃34;或＆＃34; -G＆＃34 ;. 我试图在单个工作簿中保存以-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

End Sub

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

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

1 个答案: