VBA Split multiple worksheet based on cell value

[Edward11]

Hi guys,

I had on earlier posted a thread on splitting worksheet based on the cell value. That vba has been working perfectly. Refer to link below.

VBA Split worksheet and Save to Folder based on cell value

Hi, I'm trying to do the followings using VBA: Part 1 - split my worksheet into multiple workbooks Part 2 - save that workbook into a folder based on the cell value An illustration of the format of file is as below: No. Regions Branches Customer Name 1 Region1 A Ken 2 Region1 A Ash 1...

www.mrexcel.com

However, I've been exploring to split 2 worksheets based on the similar cell value. I tried to search in the forum but I can't find any.

Refer to the sample file for better illustration.

Listing.xlsx

Shared with Dropbox

www.dropbox.com

I will need to split the 2 worksheets, namely "A" and "B" based on the similar cell value in "Bch".

I'm not sure is this feasible, can anyone give a some guides?
Appreciate any inputs. Thanks!

 

[mumps]

Before running this macro, change the existing sheet names from "A" to "Sheet1" and from "B" to "Sheet2". This is to avoid confusion with the newly created sheets.

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, i As Long, arr As Variant, key As Variant
    For Each ws In Sheets(Array("Sheet1", "Sheet2"))
        arr = ws.Range("C4", ws.Range("C" & Rows.Count).End(xlUp)).Value
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(arr, 1)
                If Not .Exists(arr(i, 1)) Then
                    .Add arr(i, 1), Nothing
                    With ws
                        .Range("A3").CurrentRegion.AutoFilter 3, arr(i, 1)
                        If Not Evaluate("isref('" & arr(i, 1) & "'!A1)") Then
                            Sheets.Add(After:=Sheets(Sheets.Count)).Name = arr(i, 1)
                            ws.AutoFilter.Range.Copy Range("A1")
                        Else
                            ws.AutoFilter.Range.Offset(1).Copy Sheets(arr(i, 1)).Cells(Sheets(arr(i, 1)).Rows.Count, "A").End(xlUp).Offset(1)
                        End If
                    End With
               End If
            Next i
        End With
        ws.Range("A3").AutoFilter
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[Edward11]

Hi mumps, thanks for the macro. It works fine.

However, instead of combining them, is is possible to keep the contents within the respective sheets?
i.e. to create a new workbook with similar "Sheet1" and "Sheet2", and keep the rows with the same cell value in Col C within the sheets.

 

[mumps]

Do you want to save the newly created workbooks? If so, how do you want to name then and do you want to save them to the same folder that contains the Listing workbook?

 

[Edward11]

Yes I will need to save the newly created workbook in the same folder. The name will be based on the cell value in Col C.

 

[mumps]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim srcWB As Workbook, ws As Worksheet, i As Long, arr As Variant, key As Variant, dic As Object, k As Variant, fnd As Range
    Set srcWB = ThisWorkbook
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In srcWB.Sheets(Array("A", "B"))
        arr = ws.Range("C4", ws.Range("C" & Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(arr, 1)
            If Not dic.Exists(arr(i, 1)) Then
                dic.Add arr(i, 1), Nothing
            End If
        Next i
    Next ws
    For Each k In dic.keys
        Set fnd = srcWB.Sheets("A").Range("C:C").Find(k, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            With srcWB.Sheets("A")
                .Range("A3").CurrentRegion.AutoFilter 3, k
                Workbooks.Add (1)
                .AutoFilter.Range.Copy Range("A1")
                .Range("A3").AutoFilter
            End With
            Set fnd = srcWB.Sheets("B").Range("C:C").Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                With srcWB.Sheets("B")
                    .Range("A3").CurrentRegion.AutoFilter 3, k
                    .AutoFilter.Range.Offset(1).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1)
                    .Range("A3").AutoFilter
                End With
            End If
            With ActiveWorkbook
                .SaveAs Filename:=srcWB.Path & "\" & k & ".xlsx"
                .Close False
            End With
        End If
    Next k
    Application.ScreenUpdating = True
End Sub

 

[Edward11]

Hi mumps, I have just tried the code, it works and the new workbook is saved in the same folder.

However, is it possible to keep the contents stay within its respective sheets?
i.e. the data rows in "Sheet1" remain in "Sheet1" and data rows in "Sheet2" remain in "Sheet2" in the new workbook

 

[mumps]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim srcWB As Workbook, ws As Worksheet, i As Long, arr As Variant, key As Variant, dic As Object, k As Variant, fnd As Range
    Set srcWB = ThisWorkbook
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In srcWB.Sheets(Array("A", "B"))
        arr = ws.Range("C4", ws.Range("C" & Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(arr, 1)
            If Not dic.Exists(arr(i, 1)) Then
                dic.Add arr(i, 1), Nothing
            End If
        Next i
    Next ws
    For Each k In dic.keys
        Set fnd = srcWB.Sheets("A").Range("C:C").Find(k, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            With srcWB.Sheets("A")
                .Range("A3").CurrentRegion.AutoFilter 3, k
                Workbooks.Add
                .AutoFilter.Range.Copy Sheets(1).Range("A1")
                Sheets(1).Columns.AutoFit
                .Range("A3").AutoFilter
            End With
            Set fnd = srcWB.Sheets("B").Range("C:C").Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                With srcWB.Sheets("B")
                    .Range("A3").CurrentRegion.AutoFilter 3, k
                    .AutoFilter.Range.Copy Sheets(2).Range("A1")
                    Sheets(2).Columns.AutoFit
                    .Range("A3").AutoFilter
                End With
            End If
            With ActiveWorkbook
                .SaveAs Filename:=srcWB.Path & "\" & k & ".xlsx"
                .Close False
            End With
        End If
    Next k
    Application.ScreenUpdating = True
End Sub

 

[Edward11]

Hi mumps, i tried to run the vba but the error "subscript out of range" came out.

I went into the debugger and it stopped at the following line.
.AutoFilter.Range.Copy Sheets(2).Range("A1")

Went to check on the workbook created, the "Sheet2" of the new workbook is not created.

 

[mumps]

That is very strange as "Workbooks.Add" should add a new workbook with 3 sheets. When I ran the macro, it worked properly. Click here to download your file.