Copy specific worksheets to a new workbook and save based on Assoc name

[MJ-Indiana]

Hello! This is my first post here and I hope I handle it correctly. My question is:

Example - I have a workbook with 6 tabs:

JSmith Statement
JSmith Detail
BDoe Statement
BDoe Detail
FJones Statement
FJones Detail


I need to write a loop to go thru all the worksheets and copy JSmith tabs to a separate workbook named JSmith. Same for BDoe and FJones. So I would end up with 3 new workbooks with 2 tabs in each workbook.

I have a tab called AssocNames with all associates names listed in column A. I was hoping to somehow reference those names and add statement/detail to the end, copy the corresponding worksheet and then be able to save that workbook with the correct associate name.

I am fairly new to code and have never written a loop in excel so I'm not sure how to start.

I have 100+ associates with 2 tabs each that will need to be copied and saved each month to their own individual workbook so I really need to automate this process.

Thank you for any assistance.

MJ

[MJ-Indiana]

I have 2 different pieces of codes that "sort of" do what I need. This first piece saves JSmith Statement into a wkbk called JSmith. Then when it comes to JSmith Detail - it overwrites the JSmith wkbk with only the detail tab. It does the same for BDoe and FJones. How can I get it to save the 2nd tab in the new wkbk without completely resaving the new wkbk.

Sub CopySheets_Overwrites()
 
Dim OldBook As Workbook
Dim ws As Worksheet
 
Set OldBook = ThisWorkbook
 
For Each ws In OldBook.Worksheets
    If ws.Visible = True Then
        ws.Copy
        ActiveWorkbook.SaveAs Filename:="C:\Users\badgems\Desktop\Internal Working Documents\" & Range("D1") & ".xlsx"
        ActiveWorkbook.Close
     End If
 Next
 
 
End Sub

[MJ-Indiana]

The 2nd piece of code does create a new wkbk for JSmith with both the statement and the detail tab but then it won't move onto BDoe and FJones.

Sub CopySheets_only_first_person()
 
Dim OldBook As Workbook
Dim ws As Worksheet
Dim wbOpen As Workbook
 
 
Set OldBook = ThisWorkbook
 
 
For Each ws In OldBook.Worksheets
    If ws.Name = Range("d1") & " Stmt" Then
        ws.Copy
        ActiveWorkbook.SaveAs Filename:="C:\Users\badgems\Desktop\Internal Working Documents\" & Range("D1") & ".xlsx"
        ActiveWorkbook.Close
     End If
    If ws.Name = Range("d1") & " Detail" Then
        Set wbOpen = Workbooks.Open("C:\Users\badgems\Desktop\Internal Working Documents\" & Range("D1") & ".xlsx")
         
        ws.Copy After:=wbOpen.Sheets(Range("D1") & " Stmt")
       
     End If
 Next
 
 
 
End Sub

[Paul_Hossler]

I'd start with something like this

The For Each ... Next is the loop that you were looking for

There's also a simple test WB I used to play with

Option Explicit
 
Sub CopyAssociates()
    Dim wbNew As Workbook, wbOld As Workbook
    Dim wsNew As Worksheet, wsOld As Worksheet, ws As Worksheet, wsAssociates As Worksheet
    Dim rAssociates As Range, rAssociate As Range
    Dim sOldPath As String, sNewPath As String
    
    Application.ScreenUpdating = False
     
    Set wbOld = ThisWorkbook
    sOldPath = wbOld.Path
    Set wsAssociates = wbOld.Worksheets("AssocNames")
    Set rAssociates = wsAssociates.Cells(1, 1).CurrentRegion
     
     
    For Each rAssociate In rAssociates.Cells
            
        If Not pvtWsExists(rAssociate.Value & " Statement") And Not pvtWsExists(rAssociate.Value & " Detail") Then
            Call MsgBox(rAssociate.Value & " does not have 2 worksheets", vbCritical + vbOKOnly, "CopyAssociates")
            GoTo NextAssociate
        End If
    
        
    
        Sheets(Array(rAssociate.Value & " Statement", rAssociate.Value & " Details")).Copy
        Set wbNew = ActiveWorkbook
        
         'delete any blank WS that might have been created
        On Error Resume Next
        Application.DisplayAlerts = False
        For Each ws In wbNew.Worksheets
            If ws.Name <> rAssociate.Value & " Statement" And ws.Name <> rAssociate.Value & " Details" Then ws.Delete
        Next
        Application.DisplayAlerts = True
        On Error GoTo 0
    
    
         'build name = this path + / + PI
        sNewPath = wbOld.Path & Application.PathSeparator & rAssociate.Value & ".xlsx"
         'delete new WB if its there
        pvtDeleteFile (sNewPath)
         'save and close new PI WB
        wbNew.SaveAs (sNewPath)
        wbNew.Close (False)
    
        wbOld.Activate
    
NextAssociate:
    
    Next
    
    Application.ScreenUpdating = True
     
     
End Sub
Private Sub pvtDeleteFile(s As String)
     'delete new WB if its there
    On Error Resume Next
    Application.DisplayAlerts = False
    Kill s
    Application.DisplayAlerts = True
    On Error GoTo 0
End Sub
 
Private Function pvtWsExists(s As String) As Boolean
    Dim i As Long
    
    i = -1
    On Error Resume Next
    i = ThisWorkbook.Worksheets(s).Index
    On Error GoTo 0
    
    
    pvtWsExists = (i <> -1)
End Function

[MJ-Indiana]

Thank you Paul! I'll try this out. I very much appreciate the help.


MJ