Split an Excel file into Multiple Sheets Based on a Specific Column

Hi guys,

I need to split a excel file in multiple sheets based on column W. Every sheets must be named based on split criteria.
After that I want to save the resulting sheets in a specific location.
Thx

Some suggestions you may fund useful:

1. Our answerers are looking to "help" more often than they are looking to "do an entire project for you for free".
2. Jump into this project yourself, when you get stuck on ONE specific hurdle, post that ONE item as a forum question.
3. Show us what you've tried in an attached sample workbook and how it's not working for you. When you're doing the work yourself, just writing out a complete example question in a forum often points you to solution before you even finish posting.
4. If you can't make any headway at all and no help is forthcoming in the free forum(s), we do have a Commercial Services forum where you can pay for assistance directly from our EF gurus."

Thank you for your reply.
I can't provide the file, contains some confidential data but I can share my work so far (you will find it below). My approach was to filter the column based on specific criteria, copy filtered cells to another sheet, save that sheet to a specific location, then clear filters and repeat the procedure for another filter criteria.
I am stuck when one of the filter criteria is missing, I don't know how to skip part of the code when a certain filter criteria is missing.
How to skip this part of the code when filter criteria NCRT is missing in column W

Range("W1").AutoFilter 23, "=NCRT"
    Cells.Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").EntireColumn.AutoFit
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("B1").Select
    
Set Target = Range("W2")

Application.Sheets(2).Name = VBA.Left(Target, 31)
SaveNameA = Sheets(2).Range("W2").Text
ActiveWorkbook.Sheets(2).Columns("W:W").Delete
ActiveWorkbook.Sheets(2).Copy
Application.ActiveWorkbook.SaveAs Filename:="C:\Users\Home\Desktop\My Folder\" & SaveNameA & ".xlsx"
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(2).Delete
Application.DisplayAlerts = True

My entire code

Sub MyProject()

Dim SaveNameA As String





Range("W1").AutoFilter 23, "=NCRT"
    Cells.Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").EntireColumn.AutoFit
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("B1").Select
    
Set Target = Range("W2")

Application.Sheets(2).Name = VBA.Left(Target, 31)
SaveNameA = Sheets(2).Range("W2").Text
ActiveWorkbook.Sheets(2).Columns("W:W").Delete
ActiveWorkbook.Sheets(2).Copy
Application.ActiveWorkbook.SaveAs Filename:="C:\Users\Home\Desktop\My Folder\" & SaveNameA & ".xlsx"
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(2).Delete
Application.DisplayAlerts = True

If Sheet1.AutoFilterMode Then Sheet1.AutoFilterMode = False

Range("W1").AutoFilter 23, "=INT"
    Cells.Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").EntireColumn.AutoFit
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("B1").Select
    
Set Target = Range("W2")

Application.Sheets(2).Name = VBA.Left(Target, 31)
SaveNameA = Sheets(2).Range("W2").Text
ActiveWorkbook.Sheets(2).Columns("W:W").Delete
ActiveWorkbook.Sheets(2).Copy
Application.ActiveWorkbook.SaveAs Filename:="C:\Users\Home\Desktop\My Folder\" & SaveNameA & ".xlsx"
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(2).Delete
Application.DisplayAlerts = True

If Sheet1.AutoFilterMode Then Sheet1.AutoFilterMode = False

Range("W1").AutoFilter 23, "=REV"
    Cells.Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").EntireColumn.AutoFit
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("B1").Select
    
Set Target = Range("W2")

Application.Sheets(2).Name = VBA.Left(Target, 31)
SaveNameA = Sheets(2).Range("W2").Text
ActiveWorkbook.Sheets(2).Columns("W:W").Delete
ActiveWorkbook.Sheets(2).Copy
Application.ActiveWorkbook.SaveAs Filename:="C:\Users\Home\Desktop\My Folder\" & SaveNameA & ".xlsx"
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(2).Delete
Application.DisplayAlerts = True

If Sheet1.AutoFilterMode Then Sheet1.AutoFilterMode = False

  
    
End Sub

I have attached the file.
Thx.

Originally Posted by Mumps1

Try:

Sub MyProject()
    Application.ScreenUpdating = False
    Dim arr As Variant, i As Long
    arr = Array("NCRT", "INT", "REV")
    For i = LBound(arr) To UBound(arr)
        If WorksheetFunction.CountIf(Range("W:W"), arr(i)) > 0 Then
            With ActiveSheet
                .Cells(1, 1).CurrentRegion.AutoFilter 23, arr(i)
                .AutoFilter.Range.Copy
                Sheets.Add After:=ActiveSheet
                Cells(1, 1).PasteSpecial xlPasteValues
                Cells.EntireColumn.AutoFit
                Range("B1").Select
                With ActiveSheet
                    .Name = Left(arr(i), 31)
                    .Columns("W:W").Delete
                    .Copy
                    With ActiveWorkbook
                        .SaveAs Filename:="C:\Users\Home\Desktop\My Folder\" & arr(i) & ".xlsx"
                        .Close False
                    End With
                End With
                Application.DisplayAlerts = False
                Sheets(2).Delete
                Application.DisplayAlerts = True
            End With
        End If
    Next i
    Range("A1").AutoFilter
    Application.ScreenUpdating = False
End Sub

If you need to add another filter criteria, simply add it to the array in the code.

Thank you very much Mumps1, It works perfectly I owe you

Originally Posted by Mumps1

You are very welcome.

Hi Mumps1,

I really appreciated your help with my request. I have another question, it is possible, adapting the script from you, to split the resulting files based on the currency?. The currency can be EUR, CHF, USD and will always be in column G (the currency may differ from file to file, in one file it may be only CHF and EUR, in another file it may be CHF, EUR and USD).
The resulting files I would like to be named like this: "INT EUR", "INT CHF" and so on. The files I want to be saved in C:\Users\Home\Desktop\My Folder\Currency. I updated the test file with currency in column G.
THX

Should it be new files or new sheets?

Sub VenA()
  c00 = "E:\Temp\"
  Application.ScreenUpdating = False
  With Sheets("W").Cells(1).CurrentRegion
    .Columns(23).AdvancedFilter xlFilterCopy, , .Parent.Range("Z1"), True
    ar = .Parent.Cells(1, 26).CurrentRegion
    .Parent.Cells(1, 26).CurrentRegion.Clear
    If IsArray(ar) Then
      For j = 2 To UBound(ar)
        .AutoFilter 23, ar(j, 1)
        .Copy
        With Workbooks.Add.Sheets(1)
          .Paste
          .Name = Left(ar(j, 1), 23)
          .Columns.AutoFit
          .Columns(23).Delete
          .Parent.SaveAs c00 & ar(j, 1), 51
          .Parent.Close 0
        End With
      Next j
      .AutoFilter
    End If
  End With
End Sub

Originally Posted by Mumps1

Do you still want to split and save the data based on "NCRT", "INT", "REV" and then split each resulting file based on currency or just split and save on currency without splitting on "NCRT", "INT", "REV"?

I want to split and save the data based on "NCRT", "INT", "REV" and then split each resulting file based on currency.

It is not necessary to quote full messages. You apparently haven't looked at the code in # 8. This is much more efficient and dynamic.

It is not necessary to always create a tab and delete it.

Sub VenA()
Dim c00 As String, j As Long, ar
  Application.ScreenUpdating = False
  c00 = "E:\Temp\Temp1\" '"C:\Users\Home\Desktop\My Folder\"
  With Sheets("W").Cells(1).CurrentRegion
    Sheets.Add.Name = "Temp"
    Cells(1).Resize(, 2) = Array("WWW", "CUU")
    .AdvancedFilter xlFilterCopy, , Range("A1:B1"), True
    ar = Cells(1).CurrentRegion
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    For j = 2 To UBound(ar)
      .AutoFilter 23, ar(j, 1)
      .AutoFilter 7, ar(j, 2)
      .Copy
      With Workbooks.Add.Sheets(1)
        .Paste
        .Name = Left(ar(j, 1), 23)
        .Columns.AutoFit
        .Columns(23).Delete
        .Parent.SaveAs c00 & ar(j, 1) & "_" & ar(j, 2), 51
        .Parent.Close 0
      End With
    Next j
    .AutoFilter
  End With
End Sub

Someone with more posts doesn't necessarily write better code

Thanks guys, both solutions provided work very well. I am grateful to you.

@Mumps1,

They seemed unnecessary to me. But of course it can be adjusted.