求助：如何用Excel VBA批量复制指定工作表中特定列至汇总表

Got it, here's a polished VBA script that implements exactly what you need. It builds on your existing column-finding logic, skips excluded sheets, aggregates the required data into the AggrProdCheck sheet, and handles edge cases like missing columns or non-existent target sheets.

Sub AggregateProductData()
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim lastRow As Long, targetLastRow As Long
    Dim productCol As Integer, noPolisCol As Integer
    Dim searchProduct As String, searchNoPolis As String
    Dim productRange As Range, noPolisRange As Range, combinedRange As Range
    
    ' Define the column headers we need to find
    searchProduct = "Product"
    searchNoPolis = "NO_POLIS_IF"
    
    ' Check if target sheet exists; create it if not
    On Error Resume Next
    Set targetWs = ThisWorkbook.Worksheets("AggrProdCheck")
    On Error GoTo 0
    
    If targetWs Is Nothing Then
        Set targetWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        targetWs.Name = "AggrProdCheck"
        ' Add headers to target sheet
        targetWs.Range("A1").Value = "Product"
        targetWs.Range("B1").Value = "NO_POLIS_IF"
    End If
    
    ' Loop through worksheets starting from the 4th one (index 4, since sheets are 1-based)
    For Each ws In ThisWorkbook.Worksheets
        ' Skip first 3 sheets and excluded sheet names
        If ws.Index >= 4 And ws.Name <> "Config" And ws.Name <> "Summary" And ws.Name <> "Check" Then
            productCol = 0
            noPolisCol = 0
            
            ' Find Product column in row 2
            On Error Resume Next
            productCol = ws.Rows(2).Find(What:=searchProduct, LookIn:=xlValues, LookAt:=xlWhole, _
                SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Column
            On Error GoTo 0
            
            ' Find NO_POLIS_IF column using your existing logic
            On Error Resume Next
            noPolisCol = ws.Rows(2).Find(What:=searchNoPolis, LookIn:=xlValues, LookAt:=xlWhole, _
                SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Column
            On Error GoTo 0
            
            ' Only proceed if both columns are found
            If productCol > 0 And noPolisCol > 0 Then
                ' Get last row with data in either column
                lastRow = ws.Cells(ws.Rows.Count, productCol).End(xlUp).Row
                If ws.Cells(ws.Rows.Count, noPolisCol).End(xlUp).Row > lastRow Then
                    lastRow = ws.Cells(ws.Rows.Count, noPolisCol).End(xlUp).Row
                End If
                
                ' Skip if no data below header (row 2)
                If lastRow > 2 Then
                    ' Define the ranges for both columns (from row 3 to lastRow)
                    Set productRange = ws.Range(ws.Cells(3, productCol), ws.Cells(lastRow, productCol))
                    Set noPolisRange = ws.Range(ws.Cells(3, noPolisCol), ws.Cells(lastRow, noPolisCol))
                    
                    ' Combine the two ranges into one (side by side)
                    Set combinedRange = Union(productRange, noPolisRange)
                    
                    ' Find the next empty row in target sheet
                    targetLastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row + 1
                    
                    ' Copy the data to target sheet
                    combinedRange.Copy
                    targetWs.Cells(targetLastRow, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False
                End If
            Else
                ' Optional: Notify user if columns are missing in a sheet
                MsgBox "Skipping sheet '" & ws.Name & "': Missing one or both required columns (" & searchProduct & "/" & searchNoPolis & ")", vbInformation
            End If
        End If
    Next ws
    
    ' Optional: Auto-fit columns in target sheet for readability
    targetWs.Columns("A:B").AutoFit
    
    MsgBox "Data aggregation completed successfully!", vbInformation
End Sub

Key Features Explained: #

• Target Sheet Handling: Automatically creates the AggrProdCheck sheet if it doesn't exist, and adds headers.
• Sheet Exclusion: Skips the first 3 worksheets plus the named excluded sheets (Config, Summary, Check).
• Column Validation: Checks if both required columns exist in each sheet before proceeding—skips sheets with missing columns and notifies you.
• Data Range Logic: Captures all rows with data in either column (so you don't miss entries if one column has blanks).
• Clean Copy-Paste: Uses value-only paste to avoid formatting issues, and clears the copy mode afterward.

How to Use: #

1. Open your Excel file.
2. Press Alt + F11 to open the VBA Editor.
3. Insert a new module: Right-click your workbook in the Project Explorer > Insert > Module.
4. Paste the code above into the module.
5. Run the macro by pressing F5 or assigning it to a button in your workbook.

内容的提问来源于stack exchange，提问作者Wassle