Customer Statement of Account

[mdasifiqbal]

Dear Friends,

I have been using below VBA for creating new xls file for each individual customers based on the criteria of customer name it filters and copy past the range from a statement containing details of more then 100 customers to individual excel sheet. now the challenge is that as the format of the report has changed and also the filtering need to be on 2 criteria i.e Location in Column "A" and Name of Customer in Column "J", i have attached the new format with some data to work on, please help me by making change to the VBA I have been using to accommodate the new requirement
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 for the Help

Asif

,

[paulked]

Hi Asif. Your post count is up to 25 now and you should be using code tags to surround any VBA code.

To do this, select your code and click the # in the editor toolbar.

It makes it so much easier to read.

Thanks

[mdasifiqbal]

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

[mdasifiqbal]

Thanks Friend for guiding