Search code examples
excelvba

Deleting duplicate header rows


I work with MS Excel spreadsheets. These spreadsheets typically have data all with the same column headings (in the first row) and these headings have unique filters applied to them.

I have a nice little Macro (or VBA script) that I can execute to manipulate the data (omit certain columns, highlight cells, sort etc.). I can run/execute this Macro on any of my spreadsheets (individually) and it works fine.

The problem comes in when I want to amalgamate/join multiple spreadsheet data into one spreadsheet (by hitting ctrl + A, copying, and pasting the data directly below the rest on one spreadsheet) and then execute the Macro once. It throws an error because of the multiple heading columns. It doesn't like those heading columns (if there are more than one on the spreadsheet).

So, my current fix is, once I've pasted all my spreadsheet data onto one spreadsheet, to highlight each heading column (except for the first one) and hit the delete button. Then I can run the Macro. OR when I am copying and pasting the data from each of the spreadsheets into one, I can highlight all the data manually and leave out the heading row, but it's time-consuming because there are sooo many columns to highlight. Either way, it's annoying to have to do that before I can run my Macro.

Surely, there is a way (programmatically using vb) to properly clear those heading rows and delete them. I could then add this code to the top section of my Macro. That'll be ideal.

I've tried this script that I got from ChatGPT but it doesn't work. If I run the script as is, I get this Message: No filters applied!

If I comment out that if/else check, it crashes with a run-time error ‘1004’ Delete method of Range class failed. And when I click on debug, ws.Rows(foundCell.Row).Delete is highlighted.

Here's the script (that does NOT work):

Sub DeleteFilteredRows()
    Dim ws As Worksheet
    Dim rng As Range
    Dim searchRange As Range
    Dim foundCell As Range
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Worksheets("special") ' Adjust the worksheet name
    
        ' Turn off filters to ensure proper deletion
    If ws.AutoFilterMode Then
        ws.AutoFilterMode = False
    Else
        MsgBox "No filters applied!", vbExclamation
        Exit Sub
    End If
    
    ' Define the range to search in (exclude the header row)
    Set searchRange = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    
    ' Find and delete rows containing "PARENT_NM"
    Set foundCell = searchRange.Find(What:="PARENT_NM", LookIn:=xlValues, LookAt:=xlWhole)
    
    Do While Not foundCell Is Nothing
        ws.Rows(foundCell.Row).Delete
        Set searchRange = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) ' Redefine search range
        Set foundCell = searchRange.Find(What:="PARENT_NM", LookIn:=xlValues, LookAt:=xlWhole)
    Loop
End Sub

Does anyone know how I can achieve this?


Solution

  • Filter the first column and delete the filtered rows.

    Sub Demo()
        Dim ws As Worksheet
        Set ws = ThisWorkbook.Worksheets("special") ' Adjust the worksheet name
        If ws.AutoFilterMode Then ws.AutoFilterMode = False
        Const KEY_VAL = "PARENT_NM"
        Application.ScreenUpdating = False
        With Range("A1").CurrentRegion
            .AutoFilter Field:=1, Criteria1:=KEY_VAL
            Dim rTab As Range, rVis As Range
            Set rTab = .Resize(.Rows.Count - 1, .Columns.Count - 1).Offset(1, 1)
            On Error Resume Next
            Set rVis = rTab.SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If rVis Is Nothing Then
                MsgBox "No matching rows"
            Else
                rVis.EntireRow.Delete
            End If
            .AutoFilter
        End With
        Application.ScreenUpdating = True
    End Sub
    

    Microsoft documentation:

    Range.Offset property (Excel)

    Range.Resize property (Excel)


    The problem comes in when I want to amalgamate/join multiple spreadsheet data into one spreadsheet (by hitting ctrl + A, copying, and pasting the data directly below the rest on one spreadsheet) and then execute the Macro once. It throws an error because of the multiple heading columns.

    btw, You can create a script to consolidate data from multiple sheets or files while skipping duplicate headers during the process, ensuring they don’t become an issue.


    Copying and pasting rows as values consumes more resources compared to directly assigning values to the target range. Pls try the revised script.

    Sub MergeMySheets()
        Dim wsSource As Worksheet, wsTarget As Worksheet
        Dim lastRow As Long, targetRow As Long
        Dim wb As Workbook, ColCnt As Long
        Dim sheetNames As Variant, srcRng As Range
        Dim i As Integer
        
        ' Define the sheet names to copy from
        sheetNames = Array("s1", "s2", "s3", "s4", "s5", "s6", "s7", "s8") ' Update as needed
        
        ' Create a new worksheet for the filtered data
        Set wb = ThisWorkbook
        
        ' Check if the sheet exists before proceeding
        On Error Resume Next
        Set wsTarget = wb.Sheets("special")
        On Error GoTo 0 ' Reset error handling
        If Not wsTarget Is Nothing Then
            ' Clear existing data in target sheet
            wsTarget.Cells.Clear
        Else
            Set wsTarget = wb.Sheets.Add
        End If
        
        targetRow = 1 ' Start pasting from the first row
        Dim firstSheet As Boolean: firstSheet = True ' Flag to track the first sheet
        
        ' Loop through the defined sheet names
        For i = LBound(sheetNames) To UBound(sheetNames)
            ' Check if the sheet exists before proceeding
            On Error Resume Next
            Set wsSource = wb.Sheets(sheetNames(i))
            On Error GoTo 0 ' Reset error handling
            
            ' If the sheet does not exist, skip it
            If Not wsSource Is Nothing Then
                ' Find last used row in source sheet
                lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
                ColCnt = wsSource.UsedRange.Columns.Count
                ' Only copy if the sheet contains data
                If Not VBA.IsEmpty(wsSource.Cells(lastRow, 1)) Then
                    If firstSheet Then
                        ' First sheet: Copy everything (including headers)
                        Set srcRng = wsSource.Range("A1", wsSource.Cells(lastRow, ColCnt))
                        firstSheet = False ' Mark that we've processed the first sheet
                    Else
                        ' Other sheets: Exclude the header (start from row 2)
                        If lastRow > 1 Then
                            Set srcRng = wsSource.Range("A2", wsSource.Cells(lastRow, ColCnt))
                        Else
                            ' If only header exists, skip this sheet
                        End If
                    End If
                    If Not srcRng Is Nothing Then
                        ' Paste values into target sheet
                        With srcRng
                            wsTarget.Cells(targetRow, 1).Resize(.Rows.Count, .Columns.Count).Value = .Value
                        End With
                    End If
                    ' Update next target row
                    targetRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row + 1
                End If
            End If
            
            ' Reset wsSource for the next loop
            Set wsSource = Nothing
            Set srcRng = Nothing
        Next i
        
        ' MsgBox "Data merged successfully! Now running the primary script.", vbInformation
        
        ' Call the primary script on the merged data
        Call FilterDataAndCreateSummary
        
    End Sub