VBA Autofilter loop, copy and paste New Worksheets

[Julmust Jaeger]

Hello,

I am trying to figure out how to loop using Autofilter so that I can create specific worksheets based on column values (copying all relevant rows) and then save each worksheet as it's own work book.

My data is essentially columns (A:P) and Rows (1:2000, with Row 1 being headers).

In Column P, I have company names. I would like to Autofilter based on company names, then copy and paste all filtered rows to a sheet that matches this company name...and then loop through this until all companies have their own worksheets populated with relevant data. Finally, I would like to save each worksheet as it's own workbook named according the company.

Related, I have tried the example in this link (VBA Question - Filter, copy, and paste to new worksheet), but keeps generating errors.

Thanks!

 

[DanteAmor]

Try this:

Sub create_worksheets_and_workbooks()
  Dim c As Range, sh As Worksheet, ky As Variant
  Dim lr As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh = Sheets("Sheet1")   'Name of the sheet with data
  lr = sh.Range("P" & Rows.Count).End(xlUp).Row
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("P2:P" & lr)
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range("A1:P" & lr).AutoFilter Columns("P").Column, ky
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      Sheets(ky).Copy
      ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ky & ".xlsx", xlOpenXMLWorkbook
      ActiveWorkbook.Close False
    Next ky
  End With
  sh.Select
  sh.ShowAllData
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[Julmust Jaeger]

Perfect, that worked very well!

If I may ask two additional questions.

1) What would an efficient way be to delete the created worksheets (after they are saved to a workbook)? I end up with 90 worksheets so it would be nice to remove them

2) Is there a way to add two specific worksheets to be copied to each generated workbook (e.g., I would like a worksheet called Template and one called Lookup that is already in the same file as my data to be saved into each company file with the data).

Thanks!

 

[DanteAmor]

1) What would an efficient way be to delete the created worksheets (after they are saved to a workbook)?...
2) Is there a way to add two specific worksheets ... called Template and ... Lookup ...

Try this:

Sub create_worksheets_and_workbooks()
  Dim c As Range, sh As Worksheet, ky As Variant
  Dim lr As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh = Sheets("Sheet1")   'Name of the sheet with data
  lr = sh.Range("P" & Rows.Count).End(xlUp).Row
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("P2:P" & lr)
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range("A1:P" & lr).AutoFilter Columns("P").Column, ky
      Sheets.add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      Sheets(Array(ky, "Template", "Lookup")).Copy
      ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ky & ".xlsx", xlOpenXMLWorkbook
      ActiveWorkbook.Close False
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
    Next ky
  End With
  sh.Select
  sh.ShowAllData
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[Julmust Jaeger]

Thanks, I am getting a RTE (1004) though saying it can't save a workbook with the same name as another open one?

 

[Julmust Jaeger]

Haha, nvm, I somehow opened a file with the same name I had been testing, thanks so much that code works perfectly!

 

[DanteAmor]

Im glad to help you, thanks for the feedback.

 

[Julmust Jaeger]

Popping in quickly, if I wanted to change it so that the ky worksheet is saved as a "Data" instead of the ky?

It's just a bit of work to go back and change the name to data in the new workbooks.

I'm trying something like this, but then it logically says there is already a worksheet with that name.

Sheets.Add(, Sheets(Sheets.Count)).Name = "List_of_Funds"

 

[Julmust Jaeger]

My probably silly solution so far was to just add

Sheets(ky).Name = "Data_Files"

after the line that copies worksheet generated from the Keys and the two two other worksheets.