Using Array in VBA to eliminate blank columns in a row

**NitroN** · 12-03-2013, 10:42 AM

Hi All,
I have a table with the following:
..........A............B................C...............D..........E ........F...........G............H
1...... Name.....Address..........Tel........... Fruit1....Fruit2...Fruit3....Fruit4.......Fruit5
2...... Detail1......................Detail2.........Txt1................Txt2....................Txt3
3...... Detail1......................Detail2.........Txt1......Txt2....Txt3

(Dots are used as spacers to keep columns in line)

The columns for Name, address & Tel are allowed to have blank columns.
The columns for Fruit1 to Fruit5 need to be consolidated to the left, leaving no blank columns.
Row 2 is the original and row 3 is how it needs to look.

I can do this using an array formula in D3:H3
{=IFERROR(INDEX($D$3:$H$3, SMALL(IF(($D$3:$H$3="")+ISERROR(($D$3:$H$3), "", COLUMN(($D$3:$H$3)-MIN(COLUMN(($D$3:$H$3))+1), COLUMN(A1))),"")}

But I need to do this in VBA.
Can anyone assist?

**TMS** · 12-03-2013, 11:37 AM

One way, though I'm sure there are better:

Sub test()

Dim iRange As Range: Set iRange = Range("D2:H2")
Dim oRange As Range: Set oRange = Range("D3:H3")
Dim vIArray
Dim vOArray
Dim i As Long
Dim j As Long
Dim awf As WorksheetFunction: Set awf = WorksheetFunction

' store input range in array
vIArray = awf.Transpose(awf.Transpose(iRange))
' resize output array to same dimensions as input array
ReDim vOArray(LBound(vIArray) To UBound(vIArray))
' initialise index (j) for output array
j = LBound(vOArray)
' loop through input array
For i = LBound(vIArray) To UBound(vIArray)
    ' if not blank
    If vIArray(i) <> "" Then
        ' move to output array
        vOArray(j) = vIArray(i)
        ' increment output index (j)
        j = j + 1
    End If
Next 'i

' restore output array to worksheet
oRange = vOArray

End Sub

Regards, TMS

**NitroN** · 12-09-2013, 08:04 AM

Hi Trevor,

I actually came up with a very similar answer, but I appreciate your input.

Regards
Neil

Sub Blankless_Array()

    Dim myArray(), myData As Range, Cell_Data As Range, ct As Integer, i As Integer

    Set myData = Worksheets(1).Range("d3:h3")

    'Copy all data in row and paste values in row3 for array purposes
    Range("A2:h2").Select
    Selection.Copy
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                  :=False, Transpose:=False
    Range("A3").Select
    Application.CutCopyMode = False

    ReDim myArray(myData.Count)

    ct = 0
    For Each Cell_Data In myData
        'don't add blanks to array
        If Cell_Data <> "" Then
            myArray(ct) = Cell_Data
            ct = ct + 1
        Else:
            ct = ct    ' + 1
        End If
    Next Cell_Data

    'overwrite range with array data
    Range("d3:h3").Value = myArray

End Sub

**TMS** · 12-09-2013, 08:37 AM

You're welcome. Thanks for the rep.

For what it's worth, my solution is quicker. But, for small amounts of data, it probably won't be that significant. Timing my routine is between 4 and 6 milliseconds; yours is between 23 and 25 milliseconds. Not a big deal when you're looking at milliseconds but, if you end up processing lots of data ...

See attached sample workbook.

HTML Code:

If you are satisfied with the solution(s) provided, please mark your thread as Solved.

New quick method:
Select Thread Tools-> Mark thread as Solved. To undo, select Thread Tools-> Mark thread as Unsolved.

Or you can use this way:

How to mark a thread Solved
Go to the first post
Click edit
Click Go Advanced
Just below the word Title you will see a dropdown with the word No prefix.
Change to Solved
Click Save

You may also want to consider thanking those people who helped you by clicking on the little star at the bottom left of their reply to your question.