VBA для разделения рабочих листов на две разные рабочие книги

Question

У меня есть рабочая книга, содержащая 30 + листы и каждая вкладка с надписью «-A» или «-G». Я пытаюсь сохранить имена вкладок, заканчивающиеся на -A, в одной книге и -G в другой книге. Я хотел бы переместить рабочие листы в новые книги, потому что я использую первый в качестве основного файла. Кроме того, иногда может быть все -A и no -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