Need VBA code to remove extra spaces between rows

[intellitechdataservices]

I want to remove the extra spaces between rows in all the sheets of entire workbook. Some rows have extra spaces. Is there any vba macro for that?

 

[iggydarsa]

This is based on Column "A"

Sub RemoveBlank()
    For Each sh In Worksheets
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        For i = lr To 2 Step -1
            If sh.Range("A" & i - 1).Value = "" Then sh.Range("A" & i - 1).EntireRow.Delete
        Next i
    Next sh
End Sub

 

[kevin9999]

Could you provide a sample of your data using the XL2BB add in, or alternatively share your (desensitised) file via Google Drive, Dropbox or similar file sharing platform?

 

[intellitechdataservices]

This is based on Column "A"

Sub RemoveBlank()
    For Each sh In Worksheets
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        For i = lr To 2 Step -1
            If sh.Range("A" & i - 1).Value = "" Then sh.Range("A" & i - 1).EntireRow.Delete
        Next i
    Next sh
End Sub

Please note that rows are not extra instead there is extra space in some of the rows of the worksheet and same with whole workbook

 

[CephasOz]

Try this (it checks all cells in each worksheet to make sure that data doesn't get deleted because A is blank):

' Collapse the used range all spreadsheets in a worksbook by eliminating blanks rows.
Sub DeleteBlankRows()
    Const cstrTitle As String = "DeleteBlankRows"
    Dim strErrMsg As String
    Dim lngRowTop As Long
    Dim lngRowBtm As Long
    Dim lngColLft As Long
    Dim lngColRyt As Long
    Dim lngRowCntr As Long
    Dim rngRow As Range
    Dim rngCell As Range
    Dim bolEmpty As Boolean
    Dim wksToUse As Worksheet
    Dim rngToUse As Range
    '
    On Error GoTo Err_Exit
    '
    For Each wksToUse In ThisWorkbook.Worksheets
        Set rngToUse = wksToUse.UsedRange
        '
        ' Get the boundaries of the range to use.
        lngRowTop = rngToUse.Cells(1).Row
        lngRowBtm = rngToUse.Cells(rngToUse.Cells.Count).Row
        lngColLft = rngToUse.Cells(1).Column
        lngColRyt = rngToUse.Cells(rngToUse.Cells.Count).Column
        '
        ' Check the rows.
        lngRowCntr = lngRowTop
        While (lngRowCntr <= lngRowBtm)
            Set rngRow = wksToUse.Range(wksToUse.Cells(lngRowCntr, lngColLft), wksToUse.Cells(lngRowCntr, lngColRyt))
            bolEmpty = True
            For Each rngCell In rngRow
                If (Not Trim(Format(rngCell.Value)) = vbNullString) Then
                    bolEmpty = False
                    Exit For
                End If
            Next
            If bolEmpty Then
                If (lngRowTop <> lngRowBtm) Then
                    rngRow.Delete xlShiftUp
                    lngRowCntr = lngRowCntr - 1
                    lngRowBtm = lngRowBtm - 1
                End If
            End If
            lngRowCntr = lngRowCntr + 1
        Wend
    Next wksToUse
Housekeeping:
    Set rngToUse = Nothing
    Set rngRow = Nothing
    Set wksToUse = Nothing
    Exit Sub
Err_Exit:
    strErrMsg = Err.Number & ": " & Err.Description
    Err.Clear
    MsgBox strErrMsg, vbCritical + vbOKOnly, cstrTitle
    Resume Housekeeping
End Sub

 

[intellitechdataservices]

Give me sometime I am uploading the link of the excel sheet