PDA

View Full Version : Copy specific worksheets to a new workbook and save based on Assoc name



MJ-Indiana
07-07-2015, 11:33 AM
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
07-07-2015, 03:03 PM
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
07-07-2015, 03:04 PM
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
07-07-2015, 04:41 PM
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
07-07-2015, 07:02 PM
Thank you Paul! I'll try this out. I very much appreciate the help.


MJ