delete blank cells, shift populated cells right

B

BonnieM

Board Regular
Joined
Nov 3, 2014
Messages
71
I have a very large spreadsheet with rows of data containing blank cells in the middle of a row.

I need to delete the blank cells within a range and shift the populated cells to the right.

I'm a vba beginner.

Tried this in "this workbook":

Sub Blanks()
Range("A1:x9").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlRight
End Sub

but got an error "X 400" which I can't even find in the help screens!

Can anybody be a hero here?
 
Sort by date Sort by votes
I was thinking about this last night and though about a better approach. I have tested this code and it appears to be working. Let me know if it works for you.

Code: 
Sub test2()
On Error GoTo EC
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim iArr()
Dim r       As Range
Dim cel     As Range
Dim x       As Long
Dim ic      As Long
Dim rs      As Integer
Dim cb      As Integer
Dim col     As New Collection

Set r = Range("C2:X51565")
r.Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        
Set r = r.SpecialCells(xlCellTypeBlanks)

For Each cel In r
    col.Add cel.Row(), CStr(cel.Row())
Next cel

For x = 1 To col.Count
    Set r = Range("C" & col(x) & ":X" & col(x))
    cb = Application.WorksheetFunction.CountBlank(r)
    rs = 22 - cb
    ReDim iArr(1 To rs)
        ic = 1
        For Each cel In r
            If cel.Value <> "" Then
                iArr(ic) = cel.Value
                ic = ic + 1
            End If
        Next cel
    r.ClearContents
    Set r = r.Resize(1, r.Cells.Count - cb).Offset(, cb)
    r.Value = iArr
Next x

Exit Sub
EC:
If Err.Number = 457 Then
    Resume Next
Else
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Here is the code annotated like you asked for.

Code: 
Sub test2()
On Error GoTo EC
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim iArr()
Dim r       As Range 'A variable range that will be resized throughout the routine
Dim cel     As Range 'A range to step through each cel in r
Dim x       As Long 'A number to step through each item in col collection
Dim ic      As Long 'A number that will iterate to add each item to iArr() array
Dim rs      As Integer 'A number that will be the difference between the non blanks and blanks on each row
Dim cb      As Integer 'A number that will be the number of blanks on each row
Dim col     As New Collection 'An array of numbers for each row in r that has blanks

Set r = Range("C2:X51565") 'Range of data
r.Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Replace all " " with ""
        
Set r = r.SpecialCells(xlCellTypeBlanks) 'Resize to just blank cells

For Each cel In r
    col.Add cel.Row(), CStr(cel.Row()) 'Add each row that has blanks to collection
Next cel

For x = 1 To col.Count 'Go through each item in collection
    Set r = Range("C" & col(x) & ":X" & col(x)) 'Resize r to specific row
    cb = Application.WorksheetFunction.CountBlank(r) 'cb = blank cell count
    rs = 22 - cb 'rs = total columns - blank cell count
    ReDim iArr(1 To rs) 'Fill array
        ic = 1 'Initialize number to iterate for array
        For Each cel In r 'for each cel in current row
            If cel.Value <> "" Then 'if the cell isn't blank
                iArr(ic) = cel.Value 'add to array
                ic = ic + 1 'Increment ic
            End If
        Next cel
    r.ClearContents 'Clear out row
    Set r = r.Resize(1, r.Cells.Count - cb).Offset(, cb) 'Resize and move range. This is where it is being shifted to the right
    r.Value = iArr 'fill range with non blank values
Next x

Exit Sub
EC:
If Err.Number = 457 Then 'To get a unique collection of rows, I add to collection.  You can't have duplicate keys in a collection.  So as it tries to add the row for each cell that is blank, if the row is the same as one that has been entered into the collection, then it will come here and be told to continue on.
    Resume Next
Else 'Any other error will give a number and description and the routine will end.
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
Tried this and got a plethora of errors. Did it run successfully on the test data I sent?

In addition to several of the common ones, subscript out of range, etc, I got 1004: ClearContents method of range class failed

It locked up and I had to close excel via Task Mgr.
 
Upvote 0
OK. I tested it on your sample data. I think the problem was that there were totally blank rows. Try this.

Code: 
Sub test2()
On Error GoTo EC
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim iArr()
Dim r       As Range 'A variable range that will be resized throughout the routine
Dim cel     As Range 'A range to step through each cel in r
Dim x       As Long 'A number to step through each item in col collection
Dim ic      As Long 'A number that will iterate to add each item to iArr() array
Dim rs      As Integer 'A number that will be the difference between the non blanks and blanks on each row
Dim cb      As Integer 'A number that will be the number of blanks on each row
Dim col     As New Collection 'An array of numbers for each row in r that has blanks

Set r = Range("C2:X24") 'Range of data
r.Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Replace all " " with ""
        
Set r = r.SpecialCells(xlCellTypeBlanks) 'Resize to just blank cells

For Each cel In r
    col.Add cel.Row(), CStr(cel.Row()) 'Add each row that has blanks to collection
Next cel

For x = 1 To col.Count 'Go through each item in collection
    Set r = Range("C" & col(x) & ":X" & col(x)) 'Resize r to specific row
    cb = Application.WorksheetFunction.CountBlank(r) 'cb = blank cell count
    If cb < 22 Then
        rs = 22 - cb 'rs = total columns - blank cell count
        ReDim iArr(1 To rs) 'Fill array
            ic = 1 'Initialize number to iterate for array
            For Each cel In r 'for each cel in current row
                If cel.Value <> "" Then 'if the cell isn't blank
                    iArr(ic) = cel.Value 'add to array
                    ic = ic + 1 'Increment ic
                End If
            Next cel
        r.ClearContents 'Clear out row
        Set r = r.Resize(1, r.Cells.Count - cb).Offset(, cb) 'Resize and move range. This is where it is being shifted to the right
        r.Value = iArr 'fill range with non blank values
    End If
Next x

Exit Sub
EC:
If Err.Number = 457 Then 'To get a unique collection of rows, I add to collection.  You can't have duplicate keys in a collection.  So as it tries to add the row for each cell that is blank, if the row is the same as one that has been entered into the collection, then it will come here and be told to continue on.
    Resume Next
Else 'Any other error will give a number and description and the routine will end.
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
Ok, we cannot globally replace the " " with "", because it distorts the data within the populated cells.

Also, this did not achieve the desired result, so I closed without saving and tried the F8 thing. It LOOKED like it was stuck in a loop at cell A2, so I changed the code as below

Sub test2()
On Error GoTo EC
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


Dim iArr()
Dim r As Range 'A variable range that will be resized throughout the routine
Dim cel As Range 'A range to step through each cel in r
Dim x As Long 'A number to step through each item in col collection
Dim ic As Long 'A number that will iterate to add each item to iArr() array
Dim rs As Integer 'A number that will be the difference between the non blanks and blanks on each row
Dim cb As Integer 'A number that will be the number of blanks on each row
Dim col As New Collection 'An array of numbers for each row in r that has blanks


Set r = Range("A2:X24") 'Range of data
r.Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Replace all " " with ""

Set r = r.SpecialCells(xlCellTypeBlanks) 'Resize to just blank cells


For Each cel In r
col.Add cel.Row(), CStr(cel.Row()) 'Add each row that has blanks to collection
Next cel


For x = 1 To col.Count 'Go through each item in collection
Set r = Range("A" & col(x) & ":X" & col(x)) 'Resize r to specific row
cb = Application.WorksheetFunction.CountBlank(r) 'cb = blank cell count
If cb < 22 Then
rs = 22 - cb 'rs = total columns - blank cell count
ReDim iArr(1 To rs) 'Fill array
ic = 1 'Initialize number to iterate for array
For Each cel In r 'for each cel in current row
If cel.Value <> "" Then 'if the cell isn't blank
iArr(ic) = cel.Value 'add to array
ic = ic + 1 'Increment ic
End If
Next cel
r.ClearContents 'Clear out row
Set r = r.Resize(1, r.Cells.Count - cb).Offset(, cb) 'Resize and move range. This is where it is being shifted to the right
r.Value = iArr 'fill range with non blank values
End If
Next x


Exit Sub
EC:
If Err.Number = 457 Then 'To get a unique collection of rows, I add to collection. You can't have duplicate keys in a collection. So as it tries to add the row for each cell that is blank, if the row is the same as one that has been entered into the collection, then it will come here and be told to continue on.
Resume Next
Else 'Any other error will give a number and description and the routine will end.
MsgBox "Error " & Err.Number & " " & Err.Description
Resume Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
End Sub

I got the error 9 subscript out of range, hit ok several times, it ignored first 8 rows of data, moved data in rows rows 11 to 24 successfully to the right, but the data from columns c and d came up as #N/A, while the data from columns A&B is correct. I'm baffled.
 
Upvote 0
The replacement of the spaces only applies to the range you specify in the code. Also, it will only replace cells that ONLY have a space, not spaces between words.

I have been writing the code dealing with ranges C:X. But if we are including columns A:X, the following code should take care of the errors you mentioned.

Code: 
Sub test2()
On Error GoTo EC
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim iArr()
Dim r       As Range 'A variable range that will be resized throughout the routine
Dim cel     As Range 'A range to step through each cel in r
Dim x       As Long 'A number to step through each item in col collection
Dim ic      As Long 'A number that will iterate to add each item to iArr() array
Dim rs      As Integer 'A number that will be the difference between the non blanks and blanks on each row
Dim cb      As Integer 'A number that will be the number of blanks on each row
Dim col     As New Collection 'An array of numbers for each row in r that has blanks

Set r = Range("A2:X24") 'Range of data
r.Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Replace all " " with ""
        
Set r = r.SpecialCells(xlCellTypeBlanks) 'Resize to just blank cells

For Each cel In r
    col.Add cel.Row(), CStr(cel.Row()) 'Add each row that has blanks to collection
Next cel

For x = 1 To col.Count 'Go through each item in collection
    Set r = Range("A" & col(x) & ":X" & col(x)) 'Resize r to specific row
    cb = Application.WorksheetFunction.CountBlank(r) 'cb = blank cell count
    If cb < 24 Then
        rs = 24 - cb 'rs = total columns - blank cell count
        ReDim iArr(1 To rs) 'Fill array
            ic = 1 'Initialize number to iterate for array
            For Each cel In r 'for each cel in current row
                If cel.Value <> "" Then 'if the cell isn't blank
                    iArr(ic) = cel.Value 'add to array
                    ic = ic + 1 'Increment ic
                End If
            Next cel
        r.ClearContents 'Clear out row
        Set r = r.Resize(1, r.Cells.Count - cb).Offset(, cb) 'Resize and move range. This is where it is being shifted to the right
        r.Value = iArr 'fill range with non blank values
    End If
Next x

Exit Sub
EC:
If Err.Number = 457 Then 'To get a unique collection of rows, I add to collection.  You can't have duplicate keys in a collection.  So as it tries to add the row for each cell that is blank, if the row is the same as one that has been entered into the collection, then it will come here and be told to continue on.
    Resume Next
Else 'Any other error will give a number and description and the routine will end.
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
One more little change

Code: 
Sub test2()
On Error GoTo EC
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim iArr()
Dim r       As Range 'A variable range that will be resized throughout the routine
Dim cel     As Range 'A range to step through each cel in r
Dim x       As Long 'A number to step through each item in col collection
Dim ic      As Long 'A number that will iterate to add each item to iArr() array
Dim rs      As Integer 'A number that will be the difference between the non blanks and blanks on each row
Dim cb      As Integer 'A number that will be the number of blanks on each row
Dim col     As New Collection 'An array of numbers for each row in r that has blanks

Set r = Range("A2:X24") 'Range of data
r.Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Replace all " " with ""
        
Set r = r.SpecialCells(xlCellTypeBlanks) 'Resize to just blank cells

For Each cel In r
    col.Add cel.Row(), CStr(cel.Row()) 'Add each row that has blanks to collection
Next cel

For x = 1 To col.Count 'Go through each item in collection
    Set r = Range("A" & col(x) & ":X" & col(x)) 'Resize r to specific row
    cb = Application.WorksheetFunction.CountBlank(r) 'cb = blank cell count
    If cb < 24 Then
        rs = 24 - cb 'rs = total columns - blank cell count
        ReDim iArr(1 To rs) 'Fill array
            ic = 1 'Initialize number to iterate for array
            For Each cel In r 'for each cel in current row
                If cel.Value <> "" Then 'if the cell isn't blank
                    iArr(ic) = cel.Value 'add to array
                    ic = ic + 1 'Increment ic
                End If
            Next cel
        r.ClearContents 'Clear out row
        Set r = r.Resize(1, r.Cells.Count - cb).Offset(, cb) 'Resize and move range. This is where it is being shifted to the right
        r.Value = iArr 'fill range with non blank values
    End If
Next x

Application.ScreenUpdating = True
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
Exit Sub
EC:
If Err.Number = 457 Then 'To get a unique collection of rows, I add to collection.  You can't have duplicate keys in a collection.  So as it tries to add the row for each cell that is blank, if the row is the same as one that has been entered into the collection, then it will come here and be told to continue on.
    Resume Next
Else 'Any other error will give a number and description and the routine will end.
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
It appears to be working, I just changed the range to encompass 10000 rows. I'll try the new code next
 
Upvote 0
The only difference is that is making sure that your calculation and screen updating get turned back on.
 
Upvote 0
fyi, new code and 20000 rows worked. I just changed range to all 51,565 rows. It's chugging along - fingers crossed!
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Delete empty cells bit shift to the right
Replies
4
Views
133
Peter_SSs
Peter_SSs
J
  • Question Question
VBA Error on Logic to Remove Rows based on Blank Cells
Replies
4
Views
357
Alex Blakenburg
A
D
  • Question Question
VBA to Remove Text Characters From Strings
Replies
5
Views
628
Fuji
F
Sufiyan97
  • Question Question
Add Auto sum in selected blank cells VBA
Replies
4
Views
336
Sufiyan97
Sufiyan97
N
  • Question Question
VBA - Intersect code being re-initiated
Replies
1
Views
182
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,268
Messages
6,171,100
Members
452,379
Latest member
IainTru

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top