I work with MS Excel spreadsheets that have data with the same column headings (in the first row). The headings have unique filters applied.
I have VBA code to manipulate the data (omit certain columns, highlight cells, sort, etc.). It works on any of my spreadsheets individually.
The problem comes in when I amalgamate/join multiple spreadsheet data into one spreadsheet (by hitting ctrl + A, copying, and pasting the data and headings directly below the rest on one spreadsheet).
The code throws an error because of the multiple heading rows.
My fix, once I've pasted all data and headings onto one spreadsheet, is to highlight each heading row (except for the first one) and hit the delete button.
Or when I copy the data and headings from each of the spreadsheets into one, I highlight the data manually and leave out the heading row.
How can I, using VBA code, delete those heading rows.
I tried this code from ChatGPT. I get
No filters applied!
If I comment out that if/else check, it generates
run-time error ‘1004’ Delete method of Range class failed.
on
ws.Rows(foundCell.Row).Delete
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
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:
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