Announcement

Collapse
No announcement yet.

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

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

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

    Hi!

    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!

    Code:
    
    
    Code:
        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
            Workbooks.Add
            ActiveSheet.Paste
            ActiveWorkbook.SaveAs Filename:=curPath & cell.Value & Format(Now, "dmmmyyyy-hhmmss") & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            ActiveWindow.Close
            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; 3 weeks ago. Reason: update

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

    Try This

    Code:
    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

    Comment

    Working...
    X