Please help: Visual Basic Code in Excel to Split an excel file into multiple files

Question

Hi,
I really need some help with the VIsual Basic code write me some VB code in excel. In essence I need a file splitter which will work through each value in the filter in two columns.

I have a file where I have already imported some data into, so it will be started from this workbook. 

The data to look at will be in the range a12 to DN the range down will need to be the last row (there is some 6000 rows)

The important row is 13 this has the headers where we need to look,
I want a filter applied to row 13 (A to DN)
It will need to look at column E (As the Primary) and column DF as the secondary.

I need it to use the filter in column E, filter on the first value (this is filter 1) then go over to column DF filter on the first item in there, copy the range it shows & paste with formatting & formula into a new worksheet.

The spreadsheet should be named the filter value in E followed by the filter value in DF & saved in the location mentioned in cell o1 of the master sheet.

I then need it to filter on the 2nd, 3rd, 4th etc in DF until it goes through all the unique values presented on the filter. Saving each resulting data set into spreadsheet again as described above.

Once it's cycled through DF It should then go back to column E filter on the second value in there, Go back to DF and filter through each value again in there (this may differ to the last) it is upon each value in DF that you create/save to new spreadsheet.

If there was 3 unique values in E & 3 different ones in DF for each in E, it would create 9 spreadsheets & none should have the same file name as we're creating for each variation.

The data set will have hundreds of rows for each value in columns E & DF, but there are only around 25 combination

The below that I used split and pasted the information ok but didn't cycle through the filters correctly

It's my first time using this, I've been trying to adapt off what someone else (better than me) did before.
PLease help, thanks in advance

Option Explicit

Sub SplitData()

    Dim masterWorkbook As Workbook

    Dim masterWorksheet As Worksheet

    Dim filterRange As Range

    Dim filterCell As Range

    Dim filteredData As Range

    Dim uniqueValues As Collection

    Dim value As Variant

    Dim filteredWorkbook As Workbook

    Dim filteredWorksheet As Worksheet

    Dim savePath As String

    ' Set the master workbook and worksheet

    Set masterWorkbook = ThisWorkbook

    Set masterWorksheet = masterWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with the actual sheet name

    ' Get the save path from cell O1

    savePath = masterWorksheet.Range("O1").value

    ' Set the range where the filter will be applied (row 13 in column E)

    Set filterRange = masterWorksheet.Range("E13:E" & masterWorksheet.Cells(Rows.Count, "E").End(xlUp).Row)

    ' Create a collection to store unique filter values

    Set uniqueValues = New Collection

    ' Loop through the filter range and collect unique values

    On Error Resume Next

    For Each filterCell In filterRange

        value = filterCell.value

        If Len(value) > 0 Then

            uniqueValues.Add value, CStr(value)

        End If

    Next filterCell

    On Error GoTo 0

    ' Loop through the unique filter values

    For Each value In uniqueValues

        ' Apply the filter to the column E

        filterRange.AutoFilter Field:=1, Criteria1:=value

        ' Get the filtered data range (excluding the header row)

        Set filteredData = masterWorksheet.Range("A13").CurrentRegion.SpecialCells(xlCellTypeVisible)

        ' Check if any visible cells exist after applying the filter on column E

        If Not filteredData Is Nothing Then

            ' Get the unique values in column DF after filtering on column E

            Dim filterRangeDF As Range

            Dim filterCellDF As Range

            Dim uniqueValuesDF As Collection

            Dim valueDF As Variant

            ' Set the range where the filter will be applied (row 13 in column DF)

            Set filterRangeDF = masterWorksheet.Range("DF13:DF" & masterWorksheet.Cells(Rows.Count, "DF").End(xlUp).Row)

            ' Create a collection to store unique filter values for column DF

            Set uniqueValuesDF = New Collection

            ' Loop through the filter range for column DF and collect unique values

            On Error Resume Next

            For Each filterCellDF In filterRangeDF

                valueDF = filterCellDF.value

                If Len(valueDF) > 0 Then

                    uniqueValuesDF.Add valueDF, CStr(valueDF)

                End If

            Next filterCellDF

            On Error GoTo 0

            ' Loop through the unique filter values for column DF

            For Each valueDF In uniqueValuesDF

                ' Apply the filter to column DF

                filterRangeDF.AutoFilter Field:=1, Criteria1:=valueDF

                ' Get the filtered data range after filtering on both column E and column DF

                Set filteredData = masterWorksheet.Range("A13").CurrentRegion.SpecialCells(xlCellTypeVisible)

                ' Check if any visible cells exist after applying the filter on column DF

                If Not filteredData Is Nothing Then

                    ' Copy the filtered data to a new workbook

                    filteredData.Copy

                    ' Create a new workbook for the filtered data

                    Set filteredWorkbook = Workbooks.Add

                    Set filteredWorksheet = filteredWorkbook.Sheets(1)

                    ' Paste the filtered data into the new workbook with formatting

                    filteredWorksheet.Range("A1").PasteSpecial xlPasteAll

                    ' Save the new workbook with the filter values as the file name

                    filteredWorkbook.SaveAs savePath & "" & value & "_" & valueDF & ".xlsx"

                    ' Close the new workbook

                    filteredWorkbook.Close SaveChanges:=False

                End If

                ' Clear the filter on column DF

                filterRangeDF.AutoFilter

            Next valueDF

        End If

        ' Clear the filter on column E

        filterRange.AutoFilter

    Next value

    ' Clear the filter on column E

    masterWorksheet.AutoFilterMode = False

End Sub

Answer 1

Thanks will give it a try in the morning.

Appreciate you taking the time to help.

Answer 2

Hi,

try this code

[Update2..]

Sub SplitData_2Filters()

'## 17/06/2023 ##

'use main filter and secondary filter

Const N As Integer = 4 '<< headers in row 4

Const fltMain$ = "C" '<<< main filter in column C

Const fltSecond$ = "F" '<<< secondary filter in column F

Const ColStart$ = "B" ' data start column

Const ColEnd$ = "H" 'data last column

Const srcName$ = "Sheet1" '<<< Source Sheet Name

'

Dim rng As Range

Dim c1 As New Collection

Dim c2 As New Collection

Dim wb1 As Workbook, wb2 As Workbook

Dim ws As Worksheet

Dim sPath As String

Dim r As Long, fld1 As Long, fld2 As Long

Dim cc1 As Variant, cc2 As Variant

'

Set wb1 = ThisWorkbook

sPath = wb1.Path

Set ws = wb1.Sheets(srcName)

'

Application.ScreenUpdating = False

Application.DisplayAlerts = False

ws.AutoFilterMode = False

r = ws.Cells(Rows.Count, fltMain).End(xlUp).Row

Set rng = ws.Range(ws.Cells(N, ColStart), Cells(r, ColEnd))

'

On Error Resume Next

For Each cc1 In ws.Range(fltMain & N + 1 & ":" & fltMain & r)

c1.Add cc1, CStr(cc1)

Next cc1

On Error GoTo 0

'

fld1 = ws.Cells(N, fltMain).Column - ws.Cells(N, ColStart).Column + 1

fld2 = ws.Cells(N, fltSecond).Column - ws.Cells(N, ColStart).Column + 1

'

ws.AutoFilterMode = False

ws.Range(ws.Cells(N, ColStart), ws.Cells(N, ColEnd)).AutoFilter ' << new line >>

'

For Each cc1 In c1 'AAA

rng.AutoFilter field:=fld1, Criteria1:=cc1

'

On Error Resume Next

For Each cc2 In ws.Range(fltSecond & N + 1 & ":" & fltSecond & r).SpecialCells(xlCellTypeVisible)

If cc2 <> "" Then

c2.Add cc2, CStr(cc2)

End If

Next

On Error GoTo 0

'

If c2.Count = 0 Then GoTo nnext 'ABC new

For Each cc2 In c2 'BBB

rng.AutoFilter field:=fld2, Criteria1:=cc2

Set wb2 = Workbooks.Add(1)

wb2.Sheets(1).Name = cc1 & "_" & cc2

rng.SpecialCells(xlCellTypeVisible).Copy

With wb2.Sheets(1).Range("A1")

.PasteSpecial Paste:=xlPasteFormats

.PasteSpecial Paste:=xlPasteValues

End With

Application.CutCopyMode = False

ActiveSheet.UsedRange.EntireColumn.AutoFit

wb2.SaveAs sPath & "" & cc1 & "_" & cc2 & ".xlsx"

wb2.Close False

rng.AutoFilter field:=fld2

Next cc2 'BBB

nnext: 'ABC new

'

rng.AutoFilter field:=fld1

Set c2 = Nothing

Next cc1 'AAA

'

ws.AutoFilterMode = False

'

Application.DisplayAlerts = True

Application.ScreenUpdating = True

'

Set c1 = Nothing

Set c2 = Nothing

MsgBox "done"

End Sub

==========================

sample

pic1

result

4 .xlsx files

=======================

Note

if you want to copy paste all

replace:

rng.SpecialCells(xlCellTypeVisible).Copy

With wb2.Sheets(1).Range("A1")

.PasteSpecial Paste:=xlPasteFormats

.PasteSpecial Paste:=xlPasteValues

End With

Application.CutCopyMode = False

with:

rng.SpecialCells(xlCellTypeVisible).Copy wb2.Sheets(1).Range("A1")