PDA

View Full Version : Customer Statement of Account



mdasifiqbal
04-17-2020, 06:09 AM
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
04-17-2020, 06:59 AM
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
04-17-2020, 07:12 AM
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
04-17-2020, 07:12 AM
Thanks Friend for guiding