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

One correction:

Have to exit when all the columns only hold empty elements:

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


RBS


"RB Smissaert" wrote in message
...
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

RB Smissaert wrote:
One correction:

Have to exit when all the columns only hold empty elements:

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


RBS

I think the first loop (after deletion of the originally posted first
loop) could be simplified without loss of execution speed:

For c = LB2 To UB2
For i = LBound(arr) To UBound(arr)
k = k + Len(arr(i, c))
Next
If k = 0 Then
'found empty column, so mark it
'------------------------------
markingArray(c) = 1
lEmptyCount = lEmptyCount + 1
End If
Next

Alan Beban

Alan Beban wrote:

I think the first loop (after deletion of the originally posted first
loop) could be simplified without loss of execution speed:

For c = LB2 To UB2
For i = LBound(arr) To UBound(arr)
k = k + Len(arr(i, c))
Next
If k = 0 Then
'found empty column, so mark it
'------------------------------
markingArray(c) = 1
lEmptyCount = lEmptyCount + 1
End If
Next

Alan Beban
I withdraw the above suggestion. I tested it only on a small array and
thus saw no significant change in speed as it unnecessarily looped
through every row of the non-empty columns.

Alan Beban

Alan,

I can't see much room for improvement with the function as I have it
currently:

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
'will just return the original array if all the elements in all columsns
'are empty or if all the columns hold at least one non-empty element
'-----------------------------------------------------------------------

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 markingArray() As Integer
Dim arr2 As Variant
Dim lDataCount 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
'as it has been declared as integer all the elements
'will have a zero before getting a value
'---------------------------------------------------
ReDim markingArray(LB2 To UB2) As Integer

For c = LB2 To UB2
For i = LB1 To UB1
If Len(Trim(arr(i, c))) 0 Then
'found data, so mark it, increase the count and move to next
column

'------------------------------------------------------------------
markingArray(c) = 1
lDataCount = lDataCount + 1
Exit For
End If
Next
Next

If lDataCount = 0 Or lDataCount = UB2 Then
'only empty columns found or no empty columns found,
'so just return the original array and exit
'--------------------------------------------------
DeleteEmptyArrayColumns = arr
Exit Function
End If

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

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

For c = LB2 To UB2
If markingArray(c) = 1 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

I haven't tested for speed, but the only line I could think of that could be
made faster is:

If Len(Trim(arr(i, c))) 0 Then

I need the trim for my particular purpose, but maybe:

If Not Trim(arr(i, c)) = Empty Then

is faster.
Will test and let you know.


RBS


"Alan Beban" wrote in message
...
Alan Beban wrote:

I think the first loop (after deletion of the originally posted first
loop) could be simplified without loss of execution speed:

For c = LB2 To UB2
For i = LBound(arr) To UBound(arr)
k = k + Len(arr(i, c))
Next
If k = 0 Then
'found empty column, so mark it
'------------------------------
markingArray(c) = 1
lEmptyCount = lEmptyCount + 1
End If
Next

Alan Beban
I withdraw the above suggestion. I tested it only on a small array and
thus saw no significant change in speed as it unnecessarily looped
through every row of the non-empty columns.

Alan Beban

"RB Smissaert" wrote...
I can't see much room for improvement with the function as I have it
currently:
....

There are a few things you could do differently. An alternative,


Function deca2(ByRef a As Variant) As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim rl As Long, ru As Long, cl As Long, cu As Long
Dim ne() As Long
Dim rv As Variant

rl = LBound(a, 1)
ru = UBound(a, 1)
cl = LBound(a, 2)
cu = UBound(a, 2)

n = cu - cl + 1
ReDim ne(1 To n) '** 1-based indexing for the column state array

k = 0
For j = cl To cu
For i = rl To ru
If Trim(a(i, j)) < "" Then '** string comp vs Len call
k = k + 1
ne(k) = j '** record the k_th nonempty column index
Exit For
End If
Next i
Next j

If k = 0 Or k = n Then
deca2 = a
Exit Function
End If

cu = cl + k - 1 '** revise cu
ReDim rv(rl To ru, cl To cu)

n = cl
For j = 1 To cu
k = ne(j) '** use the stored j_th nonempty column index
For i = rl To ru
rv(i, n) = a(i, k)
Next i
n = n + 1
Next j

deca2 = rv
End Function

RB Smissaert wrote:

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. . . .

Hi RB,

I'm studying the function in xl2000. The first change I made was to the
declaration of markingArray:

Dim markingArray() As Integer

Because markingArray is then initiated with all zeroes, I eliminated the
first loop

For c = LB2 to UB2
markingArray(c) = 0
Next

I'm still studying it.

Alan Beban

Alan,

Thanks for that tip. Will put it in.

RBS


"Alan Beban" wrote in message
...
RB Smissaert wrote:

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. . . .

Hi RB,

I'm studying the function in xl2000. The first change I made was to the
declaration of markingArray:

Dim markingArray() As Integer

Because markingArray is then initiated with all zeroes, I eliminated the
first loop

For c = LB2 to UB2
markingArray(c) = 0
Next

I'm still studying it.

Alan Beban