extract excel sheet and save in reference folder

[Nabeel]

hello all

PFA ..in given sheet in column "J" file names are under it.i have similar file name folder at desktop and sub folder in it with company name which is in sheet 3 column B & C..
all folder and sub folders are in one folder which name "Main" at desktop.

i want in sheet 1 only UM 01 data (sheet) automatically save in sub folder of UM 01 and similar all others. is this possible

result like sheet 2..mean only excel sheet in sub folder

 

[Jigar B]

PFA.. Button added in Sheet1. Make sure the path "C:\Main\Temp\" exist before you press the button. You can change the path in code as per your requirement.

Sub CreateWorkBook()
    Dim strFilePath As String
    Dim strFileName As String
    Dim c, rng As Range
    Dim LR As Long
   
    strFilePath = "C:\Main\Temp\" 'All the sub files will be saved here, edit as per your requirement, make sure this folder exist
   
    If Right(strFilePath, 1) <> "\" Then
        strFilePath = strFilePath & "\"
    End If
   
    Sheets("Sheet1").Select
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    LR = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rng = Range("A1:J" & LR)
    Range("J1:J" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AM1"), Unique:=True
   
    For Each c In Range([AM2], Cells(Rows.Count, "AM").End(xlUp))
        With rng
            .AutoFilter
            .AutoFilter Field:=10, Criteria1:=c.Value
            .SpecialCells(xlCellTypeVisible).Copy
            Set newbook = Workbooks.Add
            ActiveSheet.PasteSpecial
            Application.CutCopyMode = False
            ActiveSheet.Cells.WrapText = False
            ActiveSheet.Cells.EntireColumn.AutoFit
            Range("A1").Select
            ActiveWorkbook.SaveAs (strFilePath & c.Value & ".xlsx")
            newbook.Close
            Set newbook = Nothing
        End With
    Next c
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Columns("AM:AM").EntireColumn.Delete
    Range("A1").Select
End Sub

 

[Nabeel]

i have changed path C:\Main\UM 01\
but when i click on create file its seperate the sheet with error of path...did not save file in required path.

 

[Jigar B]

Make sure that UM 01 folder exist under C:\Main\
Macro will not create folder, it has to be created before running the macro.