Filter specific data and move it with header to new sheet - excel

Question

I have a list of 10 specific customers that I need excel to search and filter their numbers among hundred of customers in column D and when it finds them, based on their company code in column A, move the filtered range to a new sheet with a header (i want to move each customer with a header, not all of them under the same header) and name the news sheet same as the company code in column A
My Columns go from A to AC
What it looks like:
I wonder how can i pull this successfully using VBA
Adding Header to each customer:

Answer 1

Please, test the next code. It, basically, uses a dictionary to keep unique Company Codes, an array for the ten customers, a column array to faster load the dictionary:
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) + 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range, rngF1 As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF1 = Nothing
Set rngF1 = rngFilt.Resize(rngFilt.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible):
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF1 Is Nothing Then
rngF.Copy wsComp.Range("A1")
Else
Application.DisplayAlerts = False
wb.Worksheets(keyC).Delete
Application.DisplayAlerts = True
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it.
If something not clear enough, do not hesitate to ask for clarifications.

Answer 2

First create a tab by name CCList & enter all 10 company codes
for which you have to generate the report.
Secondly Paste the data in the Data tab.
Run this code.
In a new module
Sub GenerateReport()
Dim WsData As Worksheet, WsCCList As Worksheet
Dim FRow As Long, LRow As Long, FCol As Long, LCol As Long
Dim CCFrow As Long, CCLRow As Long, CCCol As Long, CCCounter As Long
Dim ValidationRng As Range, DataRng As Range, SrchString As String
Set WsData = Worksheets("Data")
Set WsCCList = Worksheets("CCList")
WsData.Activate
FRow = 1
FCol = 1
LRow = WsData.Cells(WsData.Rows.Count, FCol).End(xlUp).Row
LCol = WsData.Cells(FRow, WsData.Columns.Count).End(xlToLeft).Column
Set DataRng = WsData.Range(Cells(FRow, FCol), Cells(LRow, LCol))
WsCCList.Activate
CCFrow = 2
CCCol = 1
CCLRow = WsCCList.Cells(WsCCList.Rows.Count, CCCol).End(xlUp).Row
For CCCounter = CCFrow To CCLRow
SrchString = ""
SrchString = WsCCList.Cells(CCCounter, CCCol)
If SrchString = "" Then Exit Sub
If WsData.AutoFilterMode = True Then WsData.AutoFilterMode = False
DataRng.AutoFilter Field:=1, Criteria1:=SrchString, Operator:=xlFilterValues
On Error Resume Next
Set ValidationRng = Nothing
Set ValidationRng = WsData.AutoFilter.Range.Offset(1, 0).Resize(DataRng.Rows.Count - 1, DataRng.Columns.Count).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If ValidationRng Is Nothing Then
'do nothing
Else
Worksheets.Add After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = SrchString
DataRng.SpecialCells(xlCellTypeVisible).Copy
ActiveSheet.Range("a1").PasteSpecial
Application.CutCopyMode = False
End If
If WsData.AutoFilterMode = True Then WsData.AutoFilterMode = False
Next CCCounter
WsCCList.Select
MsgBox "Task Completed"
End Sub