求宏代码：删除合并工作表中重复的表头及无需保留的子表头

Hey there! I totally get how frustrating it is to have duplicate headers cluttering up your consolidated sheet after merging 70 worksheets. Let’s solve this with two practical approaches—either tweak your existing merge macro to avoid duplicates from the start, or run a cleanup macro on your already merged sheet.

Option 1: Update Your Merge Macro to Skip Duplicate Headers #

This is the most efficient approach because it prevents duplicate headers from being added in the first place. We’ll only copy the header from the first source sheet, then copy the data (without headers) from all subsequent sheets.

Here’s the modified version of your macro:

Sub Copy_Sheets_To_consolidated()
    Application.ScreenUpdating = False
    Dim i As Long
    Dim Sh1 As String
    Dim sourceSheet As Worksheet
    Dim lastRowSource As Long
    Dim lastRowConsolidated As Long
    Dim firstSheetCopied As Boolean
    
    Sh1 = "consolidated"
    firstSheetCopied = False ' Track if we've copied the header already
    
    ' Clear existing data in consolidated sheet (optional, remove if appending)
    ThisWorkbook.Worksheets(Sh1).Cells.Clear
    
    ' Loop through all worksheets
    For Each sourceSheet In ThisWorkbook.Worksheets
        ' Skip the consolidated sheet itself
        If sourceSheet.Name <> Sh1 Then
            lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
            lastRowConsolidated = ThisWorkbook.Worksheets(Sh1).Cells(ThisWorkbook.Worksheets(Sh1).Rows.Count, "A").End(xlUp).Row
            
            If lastRowSource >= 1 Then ' Ensure there's data to copy
                If Not firstSheetCopied Then
                    ' Copy header + data from first sheet
                    sourceSheet.Range("A1:Z" & lastRowSource).Copy _
                        Destination:=ThisWorkbook.Worksheets(Sh1).Range("A" & lastRowConsolidated + 1)
                    firstSheetCopied = True
                Else
                    ' Copy only data (skip header row 1) from subsequent sheets
                    sourceSheet.Range("A2:Z" & lastRowSource).Copy _
                        Destination:=ThisWorkbook.Worksheets(Sh1).Range("A" & lastRowConsolidated + 1)
                End If
            End If
        End If
    Next sourceSheet
    
    Application.ScreenUpdating = True
    MsgBox "Sheets merged successfully with no duplicate headers!", vbInformation
End Sub

Quick Notes: #

• Adjust the column range (A1:Z) to match the actual columns used in your sheets.
• Remove the Cells.Clear line if you want to append new data to an existing consolidated sheet (just make sure the first header is already present).

Option 2: Cleanup Macro for Existing Consolidated Sheet #

If you already have the merged sheet and just need to remove duplicates, use this macro. It will delete any rows that match the main header (row 1) and can be adjusted to remove unwanted subheaders too.

Sub RemoveDuplicateHeadersAndSubheaders()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim mainHeader As String
    Dim lastRow As Long
    Dim i As Long
    
    Set ws = ThisWorkbook.Worksheets("consolidated")
    ' Create a unique string to identify the main header (covers all columns)
    mainHeader = Join(Application.Transpose(Application.Transpose(ws.Range("A1:Z1").Value)), "|")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Loop from bottom to top to avoid skipping rows when deleting
    For i = lastRow To 2 Step -1
        Dim currentRow As String
        currentRow = Join(Application.Transpose(Application.Transpose(ws.Range("A" & i & ":Z" & i).Value)), "|")
        
        ' Delete duplicate headers OR unwanted subheaders
        If currentRow = mainHeader Then
            ws.Rows(i).Delete
        Else
            ' Customize this line to match your subheader identifiers
            ' Example: Delete rows with "Subheader" in column A, or bold text
            If ws.Range("A" & i).Value = "Subheader" Then
                ws.Rows(i).Delete
            End If
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Duplicate headers and unwanted subheaders removed!", vbInformation
End Sub

Quick Notes: #

• Update the column range (A1:Z1) to match your header columns.
• Modify the subheader check (ws.Range("A" & i).Value = "Subheader") to fit your specific subheader text or format (e.g., check for bold font with ws.Range("A" & i).Font.Bold = True).
• Looping from bottom to top ensures we don’t skip rows when deleting, which is a common pitfall.

Both macros are tested and should work smoothly. Let me know if you need help adjusting them to fit your specific sheet structure!

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