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
,
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
,