Snasui Excel Forum

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'

'
    Columns("A:J").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$J$807").AutoFilter Field:=3, Criteria1:="A123"
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ChDir "C:\Users\Kullaphorn.Won\Desktop\Tier-N FY20"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Kullaphorn.Won\Desktop\Tier-N FY20\A123.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    Windows("Test1.xlsm").Activate
End Sub

Code: Select all

Sub SplitBook()
Application.ScreenUpdating = False
Dim NB As Workbook, Name As String
Dim Data As Range, L As Long, A As Long

With ThisWorkbook.Sheets(1)
    Set Data = .Range("A1:J" & .Range("A999999").End(xlUp).Row)
    .Range("L1") = "Supplier"
    Data.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("L1"), Unique:=True
    A = .Range("L999999").End(xlUp).Row
    For L = 2 To A
        If .Range("L2") <> "" Then
            Set NB = Workbooks.Add
            Data.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("L1:L2"), CopyToRange:=NB.Sheets(1).Range("A1")
            Name = "C:\Users\Kullaphorn.Won\Desktop\Tier-N FY20\" & .Range("L2").Value & ".xlsx"
            NB.SaveAs Filename:=Name
            NB.Close
        End If
        .Range("L2").Delete Shift:=xlUp
    Next L
    
    .Columns("L").Clear
    .Range("a1").Select
End With
Application.ScreenUpdating = True
End Sub