VBA for New Format

[mdasifiqbal]

Dear Friends

I was using below command to run my report which used to create new excel sheets by filtering the name of the Customers, now i have a different layout of the excel sheet which will perform the same function but the filtering will be based on two criteria and 2nd Location, friends can you please tweek the below VBA to accommodate with the new requirements



Sub ConsolidateData()

Dim WB As Workbook
Dim wbTgt As Workbook
Dim Source As Range, cel As Range, tgt As Range
Dim Dic As Object, d
Dim Pth As String, f As String
Dim x

Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set WB = ThisWorkbook
Pth = ThisWorkbook.Path & ""

'Create unique list
With Sheet1
Set Source = Range(.Cells(6, 1), .Cells(Rows.Count, 1).End(xlUp))
On Error Resume Next
For Each cel In Source.Offset(1).Cells
x = CStr(cel.Value)
If x <> "" Then Dic.Add x, x
Next cel
On Error GoTo 0
'Create workbooks that don't exist
For Each d In Dic.keys
If Len(Dir(Pth & d & ".xlsx")) Then
'do nothing
Else
Source.Resize(, 12).Copy
Workbooks.Add
ActiveSheet.PasteSpecial xlPasteColumnWidths
ActiveWorkbook.SaveAs Pth & d & ".xlsx"
ActiveWorkbook.Close False
End If
Next d
'Set filtersource, open workbooks, clear target and copy data
Set Source = Range(.Cells(6, 1), .Cells(Rows.Count, 1).End(xlUp))
For Each d In Dic.keys
Set wbTgt = Workbooks.Open(Pth & d & ".xlsx")
Set tgt = ActiveWorkbook.Sheets("Sheet1").Cells(1, 1)
tgt.CurrentRegion.ClearContents
Source.AutoFilter 1, d
Source.Offset(-5).Resize(Source.Rows.Count + 6, 12).SpecialCells(xlCellTypeVisible).Copy
tgt.PasteSpecial xlPasteValues
tgt.PasteSpecial xlFormats
tgt.Select
wbTgt.Close True
Source.AutoFilter
Next d
End With
Application.ScreenUpdating = True
End Sub

Thanking you in advance

Asif