Excel VBA Course

(35% Sale Ends Jan. 26)

Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course (35% Discount)

split data into multiple sheets based on specific columns

0

Hi 

after long  time of  the  searching  I've  found  this  code  splits data  based on column A,B   but  my  case  need split  based  on columns  are  not  adjacent  like  column B,D,F.

my  knowladge  in  vba   is  too poor  . so  if  anybody  provide  me  to  adapt  this  code  with  my  requirement I truly appreciate .

Public Sub Split_Sheet_By_2_Columns()

    Dim rRange As Range, rCell As Range
    Dim wSheet As Worksheet
    Dim wSheetStart As Worksheet
    Dim cellA As String, cellB As String, sheetName As String

    Set wSheetStart = ActiveSheet
    With wSheetStart
        .AutoFilterMode = False


        Set rRange = .Range("A1", .Range("B" & Rows.Count).End(xlUp))
    End With
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("UniqueList").Delete
    Worksheets.Add().Name = "UniqueList"
    On Error GoTo 0
    With Worksheets("UniqueList")
        rRange.AdvancedFilter xlFilterCopy, , Worksheets("UniqueList").Range("A1"), True
        Set rRange = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With

    On Error Resume Next
    With wSheetStart
        For Each rCell In rRange
            cellA = rCell.Value
            cellB = rCell.Offset(, 1).Value
            .Range("A1").AutoFilter 1, cellA
            .Range("A1").AutoFilter 2, cellB

            'Add a sheet named as A and B cells
            sheetName = cellA & " " & cellB
            Worksheets(sheetName).Delete
            Worksheets.Add().Name = sheetName
            .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
            ActiveSheet.Cells.Columns.AutoFit
        Next rCell
    End With

    With wSheetStart
        .AutoFilterMode = False
        .Activate
    End With

    On Error GoTo 0
    Application.DisplayAlerts = True

End Sub

thanks in advance

Answer
Discuss

Discussion

Hi Ali and welcome to the Forum

Do you have data in column A but want to name sheets based on columns B, D and F? 

If you have a representative Excel file, please add it to your ORIGINAL question (using the Add Files .. button) 
John_Ru (rep: 2857) Nov 25, '21 at 10:54 am
Do you have data in column A but want to name sheets based on columns B, D and F? 
yes , and  I attached my  file .
Ali M (rep: 2) Nov 25, '21 at 11:18 am
Add to Discussion

Answers

0
Selected Answer

 Ali

Please try the modifed attached file- it includes the modified code below (changes in bold to filter on columns B, D and F rather than A and B):

Public Sub Split_Sheet_By_3_Columns()

    Dim rRange As Range, rCell As Range
    Dim wSheet As Worksheet
    Dim wSheetStart As Worksheet
    Dim cellB As String, cellD As String, cellF As String, sheetName As String

    Set wSheetStart = ActiveSheet
    With wSheetStart
        .AutoFilterMode = False


        Set rRange = .Range("A1:G" & .Range("G" & Rows.Count).End(xlUp))
    End With
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("UniqueList").Delete
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "UniqueList"
    On Error GoTo 0
    With Worksheets("UniqueList")
        rRange.AdvancedFilter xlFilterCopy, , Worksheets("UniqueList").Range("A1"), True
        Set rRange = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    End With

    On Error Resume Next
    With wSheetStart
        For Each rCell In rRange
            cellB = rCell.Offset(, 0).Value
            cellD = rCell.Offset(, 2).Value
            cellF = rCell.Offset(, 4).Value
            ' filter on 3  fields
            With .Range("B1:G" & .Range("G" & Rows.Count).End(xlUp))
                .AutoFilter Field:=1, Criteria1:=cellB
                .AutoFilter Field:=3, Criteria1:=cellD
                .AutoFilter Field:=5, Criteria1:=cellF
            End With
            'Add a sheet named as B, D and F cells
            sheetName = cellB & " " & cellD & " " & cellF
            Worksheets(sheetName).Delete
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sheetName
            .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
            ActiveSheet.Cells.Columns.AutoFit
        Next rCell
    End With

    With wSheetStart
        .AutoFilterMode = False
        .Activate
    End With

    On Error GoTo 0
    Application.DisplayAlerts = True

End Sub
If your data in Main contains several rows matching columns B, D and F (but different or repeated values in column A or others), several rows will appear in the named sheet.

I've also re-assigned the revised macro to your button on worksheet Main (so click it to create the new sheets).

Hope this works for you.

Discuss

Discussion

this is very efficient . just I would ask the sheet Unique List  . if it's possible to delete it after spliting . I don't need  it after split
Ali M (rep: 2) Nov 26, '21 at 9:47 am
Glad that works for you, thanks for selecting my Answer Ali. To remove that sheet, just add:
Worksheets("UniqueList").Delete
after the last End With statement.
John_Ru (rep: 2857) Nov 27, '21 at 1:30 am
many  thanks  for  provide me hand  of  help.
Ali M (rep: 2) Nov 28, '21 at 3:23 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login