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?
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