How to loop worksheet columns and delete shift-up when three adjacent cells are empty

Royzer · Feb 21st 2023

I am looping through a folder and copying three columns from each file to a single sheet in a single workbook. What I'd like to do is delete and shift up any range of three adjacent cells that are blank within each three column grouping.

For example, in the attached image I would need to delete A5:C5, A7:C9, E5:G7 and I4:KI4, among others. I cannot delete rows because no row will be completely blank due to the number of columns I will have once all columns have been copied into the sheet.

I'd really appreciate any help you can give me. Thanks!

rollis13 · Feb 21st 2023

As long as your empty cells don't contain formulas, have a try with this macro on your active sheet. Change last row detection method if your real sheet has other areas compiled.

Code

Option Explicit
Sub DeleteBlankRowsInAreas()
    Dim x      As Long
    Dim lr     As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    lr = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    For x = lr To 4 Step -1
        If Application.CountBlank(Range("A" & x & ":C" & x)) = 3 Then Range("A" & x & ":C" & x).Delete Shift:=xlUp
        If Application.CountBlank(Range("E" & x & ":G" & x)) = 3 Then Range("E" & x & ":G" & x).Delete Shift:=xlUp
        If Application.CountBlank(Range("I" & x & ":K" & x)) = 3 Then Range("I" & x & ":K" & x).Delete Shift:=xlUp
    Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Display More

How to loop worksheet columns and delete shift-up when three adjacent cells are empty

Participate now!

Share

Tags