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:

CodePudding user response：

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.

CodePudding user response：

1. First create a tab by name CCList & enter all 10 company codes for which you have to generate the report.

2. Secondly Paste the data in the Data tab.

3. 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