CODEWITHSUNDEEP
vbaexcel
Adam Trigg
Adam Trigg

Reputation: 53

MS Excel VBA Split multiple sheets into Multiple files

I am attempting to split multiple sheets [3] from 1 excel file into smaller files with the same 3 sheets, but smaller sections of each file, which is split by a value in 1 of the columns [same column heading that is being filtered is on all 3 sheets, but the rest of the data is different]

i am am able to do this with 1 sheet, which generates many different files for 1 sheet, but i am stuck basically applying the same auto filter to the other 2 sheets without it failing. i dont know too much about arrays

Below is the code until it breaks. note that the 1st table is Query1, and the 2nd is Query2, Export Criteria is a workbook scoped named range

Dim ArrayItem As Long
Dim ws As Worksheet
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range
Dim MainWkbk As Workbook
Dim NextWkbk As Workbook
Dim CustomerLevelRange As Range
Dim tbl As ListObject
Dim Pt As PivotTable
Dim CurrentFilter

Set MainWkbk = ActiveWorkbook
Set ws = Sheets("Customer_Level_Detailed")
SavePath = "D:\test\"
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Query1[#Headers]"), 0)
ColumnHeadingStr = "Query1[[#All],[" & Range("ExportCriteria").Value & "]]"

Application.ScreenUpdating = False
Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("UniqueValues"), Unique:=True

ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))

ws.Range("UniqueValues").EntireColumn.Clear

For ArrayItem = 2 To UBound(ArrayOfUniqueValues)

Workbooks.Add
Set NextWkbk = ActiveWorkbook
ActiveSheet.Name = "Customer_Level_Detailed"

Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Service_Level_Detailed"

'CUSTOMER_LEVEL_PASTE
MainWkbk.Activate
Sheets("Customer_Level_Detailed").Select
ws.ListObjects("Query1").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
ws.Range("Query1[#All]").SpecialCells(xlCellTypeVisible).Copy
NextWkbk.Activate
Sheets("Customer_Level_Detailed").Select
Range("A3").PasteSpecial xlPasteAll
Set CustomerLevelRange = Range(Range("A3"), Range("A3").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, CustomerLevelRange, , xlYes)
tbl.TableStyle = "TableStyleMedium15"

'SERVICE LEVEL PASTE
MainWkbk.Activate
Sheets("Service_Level_Detailed").Select
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Query2[#Headers]"), 0)
ws.ListObjects("Query2").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
' ^^ THIS IS THE POINT THE FAILURE OCCURS ^^
ws.Range("Query2[#All]").SpecialCells(xlCellTypeVisible).Copy

Next ArrayItem

ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True

Upvotes: 0

Views: 400

Answers (1)

DisplayName
DisplayName

Reputation: 13386

it's because you're using ws (defined as Sheets("Customer_Level_Detailed")) as explicit worksheet qualification for Query2 table, while that table is in Service_Level_Detailed sheet

and this wins over having previously selected the wanted sheet (Sheets("Service_Level_Detailed").Select)

so a quick and dirty fix would be changing all ws occurrences to ActiveSheet ones. like for instance:

ws.ListObjects("Query2").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)

to:

ActiveSheet.ListObjects("Query2").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)

a little more robust fix would be define a proper worksheet variable and use it

Dim serviceWs As Worksheet
Set serviceWs = Sheets("Service_Level_Detailed")

...
MainWkbk.Activate
serviceWs.Select
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Query2[#Headers]"), 0)
serviceWs.ListObjects("Query2").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
serviceWs.Range("Query2[#All]").SpecialCells(xlCellTypeVisible).Copy

but best practice would be avoiding any Select/Selection pattern and use fully qualified range objects:

    With MainWkbk.Sheets("Service_Level_Detailed") ' reference wanted sheet in wanted workbook
        ColumnHeadingInt = WorksheetFunction.Match(.Range("ExportCriteria").Value, .Range("Query2[#Headers]"), 0) ' use 'dot' to access referenced object (sheet, in this case) members (ranges, in this case)
        .ListObjects("Query2").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
        .Range("Query2[#All]").SpecialCells(xlCellTypeVisible).Copy
    End With

Upvotes: 2

Related Questions