-1

What would be the VBA code to remove blank cells randomly placed in a spreadsheet. Input

ColA   ColB   ColC   ColD   ColE
 A             B             D
 H      J             I
 F             B             O

Output Should be like:

ColA   ColB   ColC   ColD   ColE
 A      B      D
 H      J      I
 F      B      O
paul bica
  • 10,557
  • 4
  • 23
  • 42
AriKari
  • 323
  • 1
  • 5
  • 17
  • 5
    ```Range("A1:E3").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft```. – Daniel Dušek Aug 30 '15 at 15:12
  • 4
    @dee Good solution with three caveats. First, any data beyond column E will get shifted as well (depending on circumstances that could be a problem). Second, if the 'blanks' are really zero-length strings produced by formulas (not likely in OP scenario, but could happen), this will not find any blanks. Third, if no blanks are found, this will result in an error that must be trapped. – Excel Hero Aug 30 '15 at 15:20
  • @ExcelHero yes it is corect, good points! Now the OP knows all the caveats and can look for some more sofisticated solution if needed. – Daniel Dušek Aug 30 '15 at 16:05
  • @dee the no. of rows are 370k+ and columns 80+ – AriKari Aug 30 '15 at 16:14
  • make the bottom right of the range by getting rows and columns from usedrange. Range("A1:" & usedrange.columns.count & usedrange.rows.count).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft Santosh will have to find a letter from number function for the column letter. http://stackoverflow.com/questions/12796973/vba-function-to-convert-column-number-to-letter – MatthewD Aug 30 '15 at 18:40
  • What did you try doing? – brettdj Aug 31 '15 at 06:05

2 Answers2

1

This solution is very fast and is free from the three caveats listed in my comment below the OP question:

Public Sub CullValues()
    Dim i&, j&, k&, v
    v = ActiveSheet.UsedRange
    For i = 1 To UBound(v, 1)
        k = 0
        For j = 1 To UBound(v, 2)
            If Len(v(i, j)) Then
                k = k + 1
                v(i, k) = v(i, j)
                If j > k Then v(i, j) = Empty
            End If
        Next
    Next
    [a1].Resize(UBound(v, 1), UBound(v, 2)) = v
End Sub
Excel Hero
  • 14,253
  • 4
  • 33
  • 40
  • Sorry that didn't work out output was some random data placed everywhere but it removed blank cells in between but ti was useless thanks for the effort though – AriKari Aug 31 '15 at 17:02
  • It works perfectly on the sample data. Your actual data must be different in some key respect from the sample data. I am willing to help you further if you can send me the data. – Excel Hero Aug 31 '15 at 17:05
  • @Santosh Yeah, I just tested it again. Works great here with no artifacts. If you can send me a sample of your data, I'll make it work and send it back to you, working. My email address is: daniel.ferry@gmail.com – Excel Hero Aug 31 '15 at 18:05
  • Can you please share your working file via dropbox or something need to see what's wrong – AriKari Aug 31 '15 at 19:03
  • @Santosh Yes! I put it on my server. Here you go: [My working file.](http:///www.excelhero.com/samples/CullValues_excelhero.xlsm) – Excel Hero Aug 31 '15 at 19:14
  • @Santosh I received your workbook and sent it back to you, with all of the blanks removed. My code from this answer worked perfectly... on all 118635 rows... and it took just five seconds. – Excel Hero Aug 31 '15 at 20:09
  • Worked perfectly the problem I had with your code earlier is that I had a FILTER active on your sheet when I ran it. ...As stated by you. – AriKari Sep 01 '15 at 03:03
1

You should really post at least an attempt of writing the code yourself.

That said, below is a working solution.

Option Explicit
Sub remove_blanks()
    Dim lrow As Long, lcol As Long, i As Long, j As Long, k As Long, r As Long
    Dim arrData() As Variant
    Dim wb As Workbook, ws As Worksheet, myrng As Range

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    ' Range can be made dynamic
    Set myrng = ws.Range("A1:BR103068")

    arrData = myrng.Value

    For i = LBound(arrData, 1) To UBound(arrData, 1)
        r = 0
        For j = LBound(arrData, 2) To UBound(arrData, 2)
            If arrData(i, j) = Empty Then
                For k = j To UBound(arrData, 2) - 1
                    arrData(i, k) = arrData(i, k + 1)
                Next k

                ' Last element emptied after first loop
                If k = UBound(arrData, 2) And r = 0 Then
                    arrData(i, k + r) = Empty
                End If
                r = r + 1 ' counts how many empty elements removed
            End If

            ' Exits loop after spaces removed from iteration
            If j + r = UBound(arrData, 2) Then
                Exit For
            End If

            ' Accounts for consecutive empty array elements
            If arrData(i, j) = Empty Then
                j = j - 1
            End If
        Next j
    Next i

    myrng.ClearContents
    myrng.Value = arrData
End Sub

I haven't tested @Excel Hero's, but it doesn't look like it shifts all elements up the array when it finds an empty element. The below will move all elements, and then iterate to the next empty element, until it reaches a point where all elements in that item have been assessed.

Testing on 70 columns and 100,000 rows of data, the code took 80 seconds to complete.

luke_t
  • 2,935
  • 4
  • 22
  • 38