I am trying to create multiple workbooks from one workbook. Each new workbook contains data from the main workbooks table, filtered by key. I used the code from here:
Q: How can I split data into multiple workbooks/files based on column in Excel?
but I had to do some minor adjustments, basically change starting rows / columns. Now, my code fails at the step "srg.AutoFilter sCol, Key" with the error message "AutoFilter method of Range class failed.
This is my code:
Sub ExportToWorkbooks()
Const aibPrompt As String = "Which column would you like to filter by?"
Const aibtitle As String = "Filter Column"
Const aibDefault As Long = 3
Dim dFileExtension As String: dFileExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim dFolderPath As String: dFolderPath = "C:\Test\"
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
' If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
Application.ScreenUpdating = False
Dim sCol As Variant
sCol = 2
If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
If sCol = False Then Exit Sub ' canceled
Dim sws As Worksheet: Set sws = ActiveSheet
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range: Set srg = sws.Range("A10").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 3 Then Exit Sub ' not enough rows
Dim srrg As Range: Set srrg = srg.Rows(10) ' to copy column widths
Dim scrg As Range: Set scrg = srg.Columns(sCol)
Dim scData As Variant: scData = scrg.Value
' Write the unique values from the 1st column to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case insensitive
Dim Key As Variant
Dim r As Long
For r = 11 To srCount
Key = scData(r, 1)
Debug.Print Key
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Sub ' only error values and blanks
Erase scData
Dim dwb As Workbook
Dim dws As Worksheet
Dim dfcell As Range
Dim dFilePath As String
For Each Key In dict.Keys
' Add a new (destination) workbook and reference the first cell.
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
Set dfcell = dws.Range("A1")
' Copy/Paste
srrg.Copy
dfcell.PasteSpecial xlPasteColumnWidths
srg.AutoFilter sCol, Key
srg.SpecialCells(xlCellTypeVisible).Copy dfcell
sws.ShowAllData
dfcell.Select
' Save/Close
dFilePath = dFolderPath & Key & dFileExtension ' build the file path
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next Key
sws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox "Data exported.", vbInformation
End Sub
My table starts in cell A10.
Can anyone point me into the right direction?
