I needed a function to delete columns of a VBA array where all the elements
were empty.
By deleting I mean something similar as deleting columns in a sheet where
the columns move to the left.
I couldn't find such a function, so I wrote one.
As somebody may know a better one (in that case please let me know) or
somebody might find this
function useful I post it here.


Function DeleteEmptyArrayColumns(ByRef arr As Variant) As Variant

'moves data to the left if a column holds no data
'redims the final array so that no empty columns are left on the right
'---------------------------------------------------------------------

Dim LB1 As Byte
Dim LB2 As Byte
Dim UB1 As Long
Dim UB2 As Long
Dim i As Long
Dim c As Long
Dim c2 As Long
Dim markingArray As Variant
Dim arr2 As Variant
Dim lEmptyCount As Long
Dim lGetCopyCol As Long

LB1 = LBound(arr, 1)
LB2 = LBound(arr, 2)
UB1 = UBound(arr, 1)
UB2 = UBound(arr, 2)

'array to keep track of empty columns
'------------------------------------
ReDim markingArray(LB2 To UB2)

'fill markingArray with zero's (nil empty column found yet)
'----------------------------------------------------------
For c = LB2 To UB2
markingArray(c) = 0
Next

For c = LB2 To UB2
For i = LB1 To UB1
If Len(arr(i, c)) 0 Then
'found data, so move to next column
'----------------------------------
Exit For
End If
If i = UB1 Then
'found empty column, so mark it
'------------------------------
markingArray(c) = 1
lEmptyCount = lEmptyCount + 1
End If
Next
Next

If lEmptyCount = 0 Then
'no empty columns found, so just return the original array
'---------------------------------------------------------
DeleteEmptyArrayColumns = arr
Exit Function
End If

'prepare the new array to get the non-empty columns
'--------------------------------------------------
ReDim arr2(LB1 To UB1, LB2 To UB2 - lEmptyCount)

'starting column in arr2 to get copies from arr
'----------------------------------------------
lGetCopyCol = LB2

For c = LB2 To UB2
If markingArray(c) = 0 Then
'non-empty column so copy to arr2
'--------------------------------
For i = LB1 To UB1
arr2(i, lGetCopyCol) = arr(i, c)
Next
'set next column to copy to
'--------------------------
lGetCopyCol = lGetCopyCol + 1
End If
Next

DeleteEmptyArrayColumns = arr2

End Function



RBS