Excel VBA remove blank rows from specific range

Question

I have an excel macro that creates a new sheet called "Compiled", copies over the contents of every sheet in the workbook from A2 onward (so the header isn't copied). This works great, except I often get tons of completely blank rows all over the place.

My objective is to have a macro to find the last row in the Compiled sheet, and delete any fully blank rows.

Here's my current script:

Sub CombineData()

' Delete unneeded sheets




    Application.DisplayAlerts = False
    Sheets("Instructions").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("TM Contacts").Select
    ActiveWindow.SelectedSheets.Delete
    
' Add new sheet called Compiled

    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Compiled"
    Sheets("Lastname, First Name").Select
    Range("Table_1[#Headers]").Select
    Selection.Copy
    Sheets("Compiled").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A2").Select
    
' Copy all sheet contents onto one

Dim lastRowSource As Long, lastRowDest As Long, i As Long
For i = 1 To Sheets.Count
    If Not Sheets(i).Name = "Compiled" Then
        lastRowSource = Sheets(i).Cells(Sheets(i).Rows.Count, "A").End(xlUp).Row
        lastRowDest = Sheets("Compiled").Cells(Sheets("Compiled").Rows.Count, "A").End(xlUp).Row
        With Sheets(i)
            .Range(.Cells(2, "A"), .Cells(lastRowSource, "AB")).Copy Sheets("Compiled").Range(Sheets("Compiled").Cells(lastRowDest + 1, "A"), Sheets("Compiled").Cells(lastRowDest + 1 + lastRowSource, "AB"))
        End With
    End If
 Next i
 
 ' delete blank rows

        
 
 End Sub

I tried this code from an older question to delete the blank rows, which gave me an "out of range" error:

Dim myWs As Worksheet
Set myWs = ThisWorkbook.Worksheets("Compiled") 'set your sheet name
Dim lastRow As Long
lastRow = myWs.Range("A" & myWs.Rows.Count).End(xlUp).Row 'find last used row

With myWs.Range(myWs.Cells(2, "A"), myWs.Cells(lastRow, "A"))
    .Value = .Value  'convert formulas to values whithin the range from with block (column A only)
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete rows where column A is blank
End With

The error with this code appears to be at "Dim myWs As Worksheet". This is where I get the "out of range" error. I'm trying to point to the compiled worksheet.

Answer 1

If I am not wrong, you want to combine data from different worksheets into one master sheet. But your code is producing lots of empty rows in the "Compiled" sheet. That's why you want to "remove blank rows from specific range".

What I understand from your code: you want to:

1. delete sheets named "Instructions" and "TM Contacts"
2. add a new sheet "Compiled"
3. copy header from the table "Table_1" in sheet "<Last Name, First Name>" and paste it as header for sheet "Compiled"
4. copy data "A2" to "AB & last row" from all sheets to sheet "Compiled", starting from "A2"

Please check if this works:

Here I have tried to avoid .select

Option Explicit

Sub CombineData()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim lastRowDest As Long
    Dim lastRowSource As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'delete sheets named "Instructions" and "TM Contacts". also delete "Compiled", if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Instructions").Delete
    ActiveWorkbook.Worksheets("TM Contacts").Delete
    ActiveWorkbook.Worksheets("Compiled").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'add a new sheet "Compiled"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Compiled"
    
    'copy header from the table "Table_1" in sheet "Last Name, First name" and paste it as header for sheet "Compiled"
    'from your code I assume you have a data formatted as a table, "Table_1"
    ActiveWorkbook.Worksheets("Last Name, First Name").ListObjects("Table_1").HeaderRowRange.Copy
    DestSh.Range("A1").PasteSpecial xlPasteValues
        

    'copy data "A2" to "AB & last row" from all sheets to sheet "Compiled",starting from "A2"
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            With DestSh
                lastRowDest = .Range("A" & .Rows.Count).End(xlUp).Row
            End With
            
            With sh
                lastRowSource = .Range("A" & .Rows.Count).End(xlUp).Row
            End With

            'if you want to change copy range, change here
            Set CopyRng = sh.Range("A2:AB" & lastRowSource)

            With CopyRng
                DestSh.Cells(lastRowDest + 1, "A").Resize(.Rows.Count, .Columns.Count).Value = .Value
            End With

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub