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!

 

[Fluff]

"Workbooks.Add" should add a new workbook with 3 sheets

That depends on your settings. Whilst the default is 3 sheets it can be change under Options, General.

 

[mumps]

@Fluff
Good point. Thanks.

 

[Edward11]

Thanks a lot @mumps @Fluff
It's working perfectly now. I will use this to further enhance according to my needs.
Btw, as this macro will be used by a few of us, is there a way to default the new workbook to be created with 3 sheets? Like using the macro to set it as default or creating 2 worksheets in the new workbook.

 

[mumps]

As Fluff pointed out, the default setting is to create 3 sheets. You can change the setting in Options, General but this means that the new setting will apply to all workbooks added in the future. Insert this code:

Application.DisplayAlerts = False
Sheets(3).Delete
Application.DisplayAlerts = True

Directly below this line:

Workbooks.Add

This will delete the third sheet.

 

[Fluff]

If you want to add 3 sheets regardless of your default setting you can use this mod to mumps' code

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
    Dim Shts As Long
    
    With Application
      Shts = .SheetsInNewWorkbook
      .SheetsInNewWorkbook = 3
    End With
    
    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.SheetsInNewWorkbook = Shts
    Application.ScreenUpdating = True
End Sub

 

[Edward11]

It works! Once again thank you so much ? @mumps @Fluff

 

[Fluff]

Glad we could help & thanks for the feedback.