Excel VBA remove blank rows from specific range

0 votes

I have an excel macro that generates a new sheet called "Compiled," duplicates over every page's contents starting with A2 (the header is not duplicated), and creates the new sheet. This works excellently, but I frequently end up with a tonne of rows that are entirely blank.

My goal is to create a macro that will locate the last row in the compiled sheet and remove any rows that are entirely blank.

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.

Oct 23 in Others by Kithuzzz
• 20,660 points
53 views

1 answer to this question.

0 votes

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
answered Oct 23 by narikkadan
• 37,660 points

Related Questions In Others

0 votes
1 answer
0 votes
1 answer
0 votes
1 answer

Removing specific rows in an Excel file using Azure Data Factory

Under the 'Source' tab, choose the number ...READ MORE

answered Sep 23 in Others by narikkadan
• 37,660 points
187 views
0 votes
1 answer
0 votes
1 answer

Retrieve epay.info Balance with VBA and Excel

This code should log you in, provided ...READ MORE

answered Sep 5, 2018 in Blockchain by digger
• 26,720 points
449 views
0 votes
1 answer

How to load file to Excel Power query from SFTP site

Currently, I don't think there is a ...READ MORE

answered Dec 3, 2018 in Power BI by Upasana
• 8,620 points
2,199 views
0 votes
1 answer

Using VBA Excel to create a gramatically correct list

The Excel AND function is a logical ...READ MORE

answered Feb 9 in Others by gaurav
• 22,040 points
66 views
0 votes
2 answers

How to copy a formula horizontally within a table using Excel VBA?

Hi so basically, create an adjacent column ...READ MORE

answered Feb 16 in Others by Edureka
• 13,640 points
199 views
0 votes
1 answer

Remove formulas from all worksheets in Excel using VBA

Try this : Option Explicit Sub test1() ...READ MORE

answered Oct 3 in Others by narikkadan
• 37,660 points
81 views
0 votes
1 answer

How to remove Blank Rows using EPPlus Excel Package Plus

Check this answer here: https://stackoverflow.com/a/49232456/1114531.  It is checking the ...READ MORE

answered Oct 3 in Others by narikkadan
• 37,660 points
250 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP