VBA to Split Worksheets to 2 Different Workbooks

Question

I have a Workbook containing 30+ worksheets and each tab labeled " -A" or " -G". I am trying to save the tab names ending with -A in a single workbook and -G in a different workbook. I would like to move the worksheets to the new workbooks because I am using the first one as Master file. Also, sometimes there could be all -A and no -G and so on.

I am still working on the code below. I would appreciate any help! thanks!

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

@TimWilliams I agree, it should be (ws.Name, 2). Anyway I posted an answer :) — CaptainABC

CaptainABC CaptainABC · Accepted Answer · 2014-10-13T22:42:34

There you go, I know it can be made shorter and is kind of repetitive, but it should get the job done!

Let me know if this works for you.

UPDATED (Browse for folder added):

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 to Split Worksheets to 2 Different Workbooks

1 Answers