No announcement yet.

Split Excel file and save each separately based on 2 or more criteria

  • Filter
  • Time
  • Show
Clear All
new posts

  • Split Excel file and save each separately based on 2 or more criteria


    I'm trying to split a file via macro using more than one criteria.
    I used the code below (with named ranges) when I only used one criteria. (e.g. Split the files using data in column B)
    Now, I need to split the files by splitting it first with the data in column B then split it again using the data in Column C before it saves into a separate workbook.

    However, I'm not sure how to incorporate another criteria to the code below.

    Any help is appreciated. Thank you!

        Sub splitexcelfile()
        Dim cell As Range
        Dim curPath As String
        curPath = ActiveWorkbook.Path & "\"
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        For Each cell In Range("lstSalesman")
            [valSalesman] = cell.Value
            Range("myList").AdvancedFilter Action:=xlFilterCopy, _
                criteriarange:=Range("Criteria"), copyToRange:=Range("Extract"), unique:=False
            Range(Range("Extract"), Range("Extract").End(xlDown)).Copy
            ActiveWorkbook.SaveAs Filename:=curPath & cell.Value & Format(Now, "dmmmyyyy-hhmmss") & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            Range(Range("Extract"), Range("Extract").End(xlDown)).ClearContents
        Next cell
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    Click image for larger version

Name:	Sample.jpg
Views:	1
Size:	27.9 KB
ID:	1158577
    Last edited by angelring13; September 28th, 2017, 21:43. Reason: update

  • #2

    Based on salesman? column B row 2? Cut and paste into other sheet?

    Try This

    Dim lr As Long
    Dim i As Long
    Dim Joseph As Object
    lr = Cells(Rows.Count, 1).End(xlUp).Row
        With Range("A:N" & lr)
        Set Joseph = .Find(what:="Joseph", LookAt:=xlWhole)
    If Not Joseph Is Nothing Then
    For i = lr To 2 Step -1
        If Range("B" & i).Value = Joseph Then
            Range("B" & i).EntireRow.Cut Sheets("Joseph").Range("A" & Rows.Count).End(3)(2)
        End If
    Next i
    End If
        End With
    On Error Resume Next
    Range("B2:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlUp
    Application.ScreenUpdating = True
    End Sub