過濾特定資料并將其與標題一起移動到新作業表

我有一個包含 10 個特定客戶的串列，我需要 excel 在 D 列中的數百個客戶中搜索和過濾他們的號碼，當它找到他們時，根據他們在 A 列中的公司代碼，將過濾后的范圍移動到一個新的作業表中標題（我想用標題移動每個客戶，而不是所有客戶都在同一個標??題下）并將新聞表命名為與 A 列中的公司代碼相同

我的專欄從 A 到 AC

它看起來像什么：

我想知道如何使用 VBA 成功地拉這個

為每個客戶添加標題：

uj5u.com熱心網友回復：

請測驗下一個代碼。基本上，它使用一個字典來保存唯一的公司代碼，一個十個客戶的陣列，一個列陣列來更快地加載字典：

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

請在測驗后發送一些反饋。

如果有些事情不夠清楚，請不要猶豫，要求澄清。

uj5u.com熱心網友回復：

1. 首先創建一個名為CCList的選項卡并輸入您必須為其生成報告的所有 10 個公司代碼。

2. 其次將資料粘貼到資料選項卡中。

3. 運行此代碼。

在一個新模塊中

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

標籤：擅长vba

上一篇：獲取沒有作業表規范的Listobject范圍

下一篇：在單元格范圍內查找“NAME”并回傳另一個單元格中查找“NAME”上方的“TEXT”幾個單元格