VBA to create multiple workbooks based on sheet cell

[kweaver]

I have tried various approaches I've seen on the internet to no avail.
I have a workbook with a worksheet named "Reformatted". In P1 I have the text: SUPER
In the rest of column P I have 2-character codes.

I'd like to loop through this sheet and create a number of additional workbooks, each with 1 sheet.
That 1 sheet would be the filtered columns A to O based on each unique value in column P (starting in row 2).

So, if I have 10 rows with P2:P_whatever that contain "DT" for example, I want those 10 rows, columns A to O in a new workbook and it can be named "DT".
Then, looping, I want to re-filter to find the next set of rows with another "SUPER" in that P column and create another workbook.

I do have a string that contains the PATH where I want all the workbooks save.

Am I clear enough or need to provide more info?

Thanks in advance.

 

[DanteAmor]

Try this

Change wPath for your folder.

Sub Test()
  Dim sh As Worksheet, c As Range, ky As Variant, wb As Workbook, wPath As String, lr As Long
  
  Application.SheetsInNewWorkbook = 1
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = Sheets("Reformatted")
[COLOR=#ff0000]  wPath = "C:\trabajo\books\"[/COLOR]
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Range("P" & Rows.Count).End(xlUp).Row
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("P2:P" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      sh.Range("A1").AutoFilter 16, ky
      Set wb = Workbooks.Add
      sh.AutoFilter.Range.Range("A[B][COLOR=#ff0000]2[/COLOR][/B]:O" & lr).Copy Range("A1")  'Change 2 to 1 if you also want to copy the header.
      wb.SaveAs wPath & ky
      wb.Close False
    Next
  End With
  sh.ShowAllData
End Sub

 

[kweaver]

FANTASTIC! Thank you, Dante...very much appreciated!

Kevin

 

[DanteAmor]

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

 

[kweaver]

Dante (or whomever)...
While this works perfectly, I have a follow-up.

If this is run twice on the same data, the files are overwritten. What would I need to add to give the user an option of overwriting or skipping?
Also, if any of the originally created files are open, this routine causes an error. What would I need to do to get around that (maybe, if open close the file, then warn per the above?)

Thanks.

 

[DanteAmor]

Change this line

Application.DisplayAlerts = False

By

On Error Resume Next

 

[kweaver]

Thanks. That seems to handle the case if the file already exists. But, if the file is open, it seems to ignore that situation when I think it should close the file then continue to recreate a new one.

 

[DanteAmor]

But, if the file is open, it seems to ignore that situation when I think it should close the file then continue to recreate a new one.

That may be a problem, since if the file was opened with another instance of excel, you would have to search all instances of excel. And that is not simple, I once tried, but I did not find the code.

But let's try this:

Sub Test()
  Dim sh As Worksheet, c As Range, ky As Variant, wb As Workbook, wPath As String, lr As Long
  
  Application.SheetsInNewWorkbook = 1
  Application.ScreenUpdating = False
  
  On Error Resume Next
  Set sh = Sheets("Reformatted")
  wPath = "C:\trabajo\books\"
  
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Range("P" & Rows.Count).End(xlUp).Row
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("P2:P" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      sh.Range("A1").AutoFilter 16, ky
      Set wb = Workbooks.Add
      sh.AutoFilter.Range.Range("A2:O" & lr).Copy Range("A1")  'Change 2 to 1 if you also want to copy the header.
[COLOR=#ff0000]      Workbooks(ky & ".xlsx").Close False[/COLOR]
      wb.SaveAs wPath & ky
      wb.Close False
    Next
  End With
  sh.ShowAllData
End Sub

 

[kweaver]

Yes, that's pretty tricky. This minor adjustment you did in RED didn't do it, unfortunately. I think I can live without this issue.
Thanks, as usual, for your expert help.

 

[DanteAmor]

If it is open with the same instance of Excel, then close it, I tried it and it works for me.