Copy and automatically save sheets from a workbook to separate workbooks

[gingerbreadgrl]

Hi,

I have a spreadsheet that is downloaded from a data source. I currently have a macro that takes each row and creates a new sheet for the row, renames it, transposes the data, and deletes any empty rows in the new sheet. I would like to automatically save each sheet to a new workbook, with the file name of the workbook being the same as the sheet name in the original workbook. One more thing to note is that the sheet is only created if there is data in the row, so it is conditional, with the exception of the first record, because there will always be at least one. Any insight would be much appreciated!

' Rename sheet that has been exported from PS with the name structure "Client-Onboarding-DATE"


ActiveSheet.Name = "Client Onboarding"


' Create the Summary Report for each client
' Add a new sheet it will automatically be named Sheet 2


Sheets.Add After:=ActiveSheet


' Copy and paste the column headings from Client Onboarding for the 1st record to a new worksheet, transposing the data from row to column


Sheets("Client Onboarding").Range("A1:HW1").Copy


Sheets(2).Range("A1").Select


Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks:=False, Transpose:=True


' Copy and paste the 1st record's data from Client Onboarding to a new worksheet, transposing the data from row to column


Sheets("Client Onboarding").Range("A2:HW2").Copy


Sheets(2).Range("B1").Select


Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks:=False, Transpose:=True


' Delete any empty rows that do not contain client data from Record 1


On Error Resume Next
Sheets(2).Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0


' Rename sheet to C1's last name and the matter number


ActiveSheet.Name = Sheets("Client Onboarding").Range("T2") & " " & Sheets(2).Range("B1")


' Format the data in Record 1 worksheet to align left and autofit the column width


Sheets(2).Columns("A").HorizontalAlignment = xlLeft
Sheets(2).Columns("A").ColumnWidth = 47
Sheets(2).Columns("A").WrapText = True


Sheets(2).Columns("B").HorizontalAlignment = xlLeft
Sheets(2).Columns("B").ColumnWidth = 47
Sheets(2).Columns("B").WrapText = True

' If there is a 2nd record exported into the workbook, create a summary worksheet for that new record. This includes:
    ' 1. Create a new worksheet.
    ' 2. Rename the worksheet to C1's last name and the matter number.
    ' 3. Transpose the column headings and that particular record's data into the summary worksheet.
    ' 4. Delete any empty rows from the data.
    ' 5. Format data.


If Sheets("Client Onboarding").Range("A3").Value > 0 Then


Sheets.Add After:=ActiveSheet


Sheets("Client Onboarding").Range("A1:HW1").Copy


Sheets(3).Range("A1").Select


Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks:=False, Transpose:=True


Sheets("Client Onboarding").Range("A3:HW3").Copy


Sheets(3).Range("B1").Select


Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks:=False, Transpose:=True


On Error Resume Next
Sheets(3).Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0


Sheets(3).Columns("A").HorizontalAlignment = xlLeft
Sheets(3).Columns("A").ColumnWidth = 47
Sheets(3).Columns("A").WrapText = True


Sheets(3).Columns("B").HorizontalAlignment = xlLeft
Sheets(3).Columns("B").ColumnWidth = 47
Sheets(3).Columns("B").WrapText = True
      
ActiveSheet.Name = Sheets("Client Onboarding").Range("T3") & " " & Sheets(3).Range("B1").Value


End If

Thanks!
Gingerbreadgrl

 

[Fluff]

Yes there is, but where do you want to save them?

 

[DanteAmor]

, but is there a way that I can designate the pathway?

Thanks!!

Try this

Sub save_sheets_to_workbook()
  Dim sh As Worksheet, c As Range, sh2 As Worksheet, [COLOR=#0000ff]folder As String[/COLOR]
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = ActiveSheet
  sh.Name = "Client Onboarding"
  '
[COLOR=#0000ff]  With Application.FileDialog(msoFileDialogFolderPicker)[/COLOR]
[COLOR=#0000ff]      .Title = "Select folder"[/COLOR]
[COLOR=#0000ff]      .AllowMultiSelect = False[/COLOR]
[COLOR=#0000ff]      If .Show <> -1 Then Exit Sub[/COLOR]
[COLOR=#0000ff]      folder = .SelectedItems(1)[/COLOR]
[COLOR=#0000ff]  End With[/COLOR]
  '
  For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
    Sheets.Add(, Sheets(Sheets.Count)).Name = sh.Range("T" & c.Row) & " " & c.Value
    Set sh2 = ActiveSheet
    sh.Range("1:1," & c.Row & ":" & c.Row).copy
    sh2.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    sh2.Columns("A:B").HorizontalAlignment = xlLeft
    sh2.Columns("A:B").ColumnWidth = 47
    sh2.Columns("A:B").WrapText = True
    On Error Resume Next
    sh2.Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    sh2.copy
    ActiveWorkbook.SaveAs [COLOR=#0000ff]folder [/COLOR]& "\" & sh2.Name & ".xlsx", xlOpenXMLWorkbook
    ActiveWorkbook.Close False
  Next
End Sub

 

[Fluff]

If it's a set path you want to use, try

Sub gingerbreadgrl()
   Dim Cl As Range
   Dim Ws As Worksheet
   Dim Pth As String
   
   Pth = [COLOR=#ff0000]"C:\Mrexcel\Fluff\"[/COLOR]
   With ActiveSheet
      .Name = "Client Onboarding"
      For Each Cl In .Range("A2:A" & .Range("T" & Rows.Count).End(xlUp))
         Set Ws = Sheets.Add(, Sheets(.Index))
         Ws.Range("A1:A231").Value = Application.Transpose(.Range("A1:HW1").Value)
         Ws.Range("B1:B231").Value = Application.Transpose(Cl.Resize(, 231).Value)
         Ws.Name = Cl.Offset(, 19).Value & " " & Ws.Range("B1").Value
         [COLOR=#0000ff]On Error Resume Next[/COLOR]
         Ws.Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
         [COLOR=#0000ff]On Error GoTo 0[/COLOR]
         With Ws.Range("A:B")
            .HorizontalAlignment = xlLeft
            .ColumnWidth = 47
            .WrapText = True
         End With
         Ws.Copy
         ActiveWorkbook.SaveAs Pth & ActiveSheet.Name, 51
         ActiveWorkbook.Close False
      Next Cl
   End With
End Sub

Just change the part in red to suit.
I've also modified the code incase there are no blanks in col B.

 

[gingerbreadgrl]

Okay, I was able to get it to save to the right place by inserting the following into the code!

ActiveWorkbook.SaveAs "G:\My Drive\Gingerbreadgrl\Client Onboarding" & ActiveSheet.Name & " Onboarding Summary", 51

Thank you both so much for all of your help. This is amazing!!!

 

[Fluff]

Glad to help & thanks for the feedback.
Not sure whose code you're using, but if it's mine please note the changes in blue I showed in post#13, This prevents the code from crashing if there are no blanks in col B.
Only realised I hadn't added it when I saw DanteAmor's code.

 

[gingerbreadgrl]

Okay I updated the code to reflect the revisions

 

[Fluff]

 

[DanteAmor]

Thank you both so much for all of your help. This is amazing!!!

I'm glad to help you. Thanks for the feedback.

 

[gingerbreadgrl]

Hi again!

I was able to get the previous code provided to work, but it has stopped working for whatever reason, I'm not sure why. I think that I might have added columns to the spreadsheet, but I'm not sure that is the issue because it seems to not work right off the bat. The error provided by Microsoft is "Run-time error '1004'" Application-defined or object-defined error." When I go to debug, this particular line of code is highlighted:

For Each Cl In .Range("A2:A" & .Range("T" & Rows.Count).End(xlUp))

Here is the entire code, it might be easier for me to figure out what is doing on if I understand what each line is, so I've attempted to make comments in front of each line, which is just my best guess as to what is happening... I would welcome any revisions to my comments that are incorrect. Most of the time there will not be more than 8 rows, and there are currently 265 rows (ending at column JE), this could change in the future and I would need to change the code to match any columns subtracted or added. I also would like to change the worksheet name to the value of the cell in column D.

Sub ClientOnboardingSummaryMacro()
   
  Dim Cl As Range
   Dim Ws As Worksheet
   Dim Pth As String
   
   Pth = "G:\My Drive\Gingerbreadgrl\Onboarding\Onboarding Summary Destination\"
   With ActiveSheet
      .Name = "Client Onboarding"
' Count the rows and columns, for the rows- look at column A starting at A2, for columns- go to column JE
      For Each Cl In .Range("A2:A" & .Range("JE" & Rows.Count).End(xlUp))
         Set Ws = Sheets.Add(, Sheets(.Index))
' Take rows from 1 to 265 and transpose them
         Ws.Range("A1:A265").Value = Application.Transpose(.Range("A1:JE1").Value)
' Not sure what this row does...
         Ws.Range("B1:B265").Value = Application.Transpose(Cl.Resize(, 265).Value)
' Name the worksheet, I would like the name of the worksheet to be the value of cell D in the spreadsheet
         Ws.Name = Cl.Offset(, 19).Value & " " & Ws.Range("B1").Value
         On Error Resume Next
' Delete any blank cells from column B on the worksheet after the data has been transposed
         Ws.Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
         On Error GoTo 0
         With Ws.Range("A:B")
            .HorizontalAlignment = xlLeft
            .ColumnWidth = 47
            .WrapText = True
         End With
         Ws.Copy
         ActiveWorkbook.SaveAs Pth & ActiveSheet.Name, 51
         ActiveWorkbook.Close False
      Next Cl
   End With

End Sub

@Fluff maybe you could take a peek? You provided me with the original code, for which I am very grateful!

Best,
Gingerbreadgrl

 

[Fluff]

Make this change as shown

For Each Cl In .Range("A2:A" & .Range("JE" & Rows.Count).End(xlUp).Row)