VIP
Trusted Members
June 25, 2016
Hi David
See if this helps. Those in red are add/changed by me.
I have to copy the header from the "Header" worksheet as the header from your active sheet (MFC FC OUTPUT) is hidden by the advanced filter and cannot be copied.
Sub Generate()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
iCol = 4 '### Define your criteria column
strOutputFolder = "SMTL_FC" '### Define your path of output folder
Set Wb = ActiveWorkbook
Set ws = ThisWorkbook.ActiveSheet '### Don't edit below this line
Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)
If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder
For Each strItem In rngUnique
If strItem <> "" Then
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
Workbooks.Add
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A7]
Wb.Worksheets("Header").Range("A1:J7").Copy Destination:=[A1]
strFilename = strOutputFolder & "\" & strItem
Cells.Select
Selection.Columns.AutoFit
ActiveWorkbook.SaveAs Filename:=strFilename & "_Fcst", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close savechanges:=False
End If
Next
ws.ShowAllData
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Selection.AutoFilter
End Sub
1 Guest(s)