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]

How about

Sub gingerbreadgrl()
   Dim Cl As Range
   Dim Ws As Worksheet
   
   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
         Ws.Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
         With Ws.Range("A:B")
            .HorizontalAlignment = xlLeft
            .ColumnWidth = 47
            .WrapText = True
         End With
         Ws.Copy
         ActiveWorkbook.SaveAs ActiveSheet.Name, 51
         ActiveWorkbook.Close False
      Next Cl
   End With
End Sub

 

[DanteAmor]

Try this

Sub save_sheets_to_workbook()
  Dim sh As Worksheet, c As Range, sh2 As Worksheet
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = ActiveSheet
  sh.Name = "Client Onboarding"
  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
    sh2.copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sh2.Name & ".xlsx", xlOpenXMLWorkbook
    ActiveWorkbook.Close False
  Next
  MsgBox "End"
End Sub

 

[gingerbreadgrl]

Hi Fluff and DanteAmor,

Thanks so much for your responses. Unfortunately, I'm not able get either code to work. Here are the details:

Fluff, I am getting an error "Run-time error 1004: Application-defined or object-defined error" and it happens at the line of code in red:

Dim Cl As Range
   Dim Ws As Worksheet
   
   With ActiveSheet
      .Name = "Client Onboarding"
      [COLOR=#ff0000]For Each Cl In .Range("A2:A" & .Range("T" & Rows.count).End(xlUp))[/COLOR]
         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
         Ws.Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
         With Ws.Range("A:B")
            .HorizontalAlignment = xlLeft
            .ColumnWidth = 47
            .WrapText = True
         End With
         Ws.Copy
         ActiveWorkbook.SaveAs ActiveSheet.Name, 51
         ActiveWorkbook.Close False
      Next Cl
   End With

DanteAmor, your code does not error and as I step through it, it creates the sheets, in the right format, but it does not delete the rows that do not contain client data (so column A has all of the heading and column B has the data, if a cell is blank in row B the row needs to delete). It also does not save the files for some reason...

Thank you both for your help and hopefully we can get one of these options to work!

 

[Fluff]

Oops, it should be

 For Each Cl In .Range("A2:A" & .Range("T" & Rows.Count).End(xlUp)[COLOR=#ff0000].Row[/COLOR])

 

[gingerbreadgrl]

Hi Fluff,

Thanks that fixed the error! So now everything looks like its working correctly and I see the pauses as the new workbooks are being created. But, I'm not sure where they are saving. I thought it would be in the folder that the original workbook is saved but I don't see the files there. I'm not sure where they are being saved...

 

[DanteAmor]

Try this
The files are saved in the same folder where you have the file with the macro.

Sub save_sheets_to_workbook()
  Dim sh As Worksheet, c As Range, sh2 As Worksheet
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = ActiveSheet
  sh.Name = "Client Onboarding"
  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
[COLOR=#0000ff]    On Error Resume Next[/COLOR]
[COLOR=#0000ff]    sh2.Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete[/COLOR]
[COLOR=#0000ff]    On Error GoTo 0[/COLOR]
    sh2.copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sh2.Name & ".xlsx", xlOpenXMLWorkbook
    ActiveWorkbook.Close False
  Next
End Sub

 

[gingerbreadgrl]

Okay I found them! They are under this PC, documents, is there any way to designate a specific file for them to save in? Thanks!

 

[Fluff]

Where do you want them saved?

 

[gingerbreadgrl]

Sorry about that, I wasn't clear in my last response.

Fluff, the files are saving under This PC/Documents

DanteAmore, the files are saving in a App Data/Roaming folder that I don't know how to access, I just see it by clicking on window + e, although I see in the code that it is supposed to be saving in the folder that the original workbook is in.

Perhaps this is because I use google drive to save documents. I'm not sure, but is there a way that I can designate the pathway?

Thanks!!