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:

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

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

Thanks for that.
I presume this will give the same result but makes it faster.
Did you test for speed and if so what roughly was the difference?

RBS


"Harlan Grove" wrote in message
...
"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 presume this will give the same result but makes it faster.
Did you test for speed and if so what roughly was the difference?

It's about 10% faster on average, but both are quite fast.

I believe that Harlan Grove's function below, as well as Bart
Smissaert's last posted one, has a problem with 0-based arrays. I think
the problem resides, in Harlan Grove's, in

n = cu - cl + 1

but the fix wasn't obvious to me.

In Bart Smissaert's the fix seems to be in changing

If lDataCount = 0 Or lDataCount = UB2 to

If lDataCount = 0 Or lDataCount = UB2 - LB2 + 1

*But* each should probably be more thoroughly tested.

Alan Beban

Harlan Grove wrote:
"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

Alan,

Yes, that was a bug indeed.
I had taken the 0-based and 1-based difference into acount further on in the
function, but had forgotten with this marking array.
For clarity I would do:

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


RBS

"Alan Beban" wrote in message
...
I believe that Harlan Grove's function below, as well as Bart
Smissaert's last posted one, has a problem with 0-based arrays. I think
the problem resides, in Harlan Grove's, in

n = cu - cl + 1

but the fix wasn't obvious to me.

In Bart Smissaert's the fix seems to be in changing

If lDataCount = 0 Or lDataCount = UB2 to

If lDataCount = 0 Or lDataCount = UB2 - LB2 + 1

*But* each should probably be more thoroughly tested.

Alan Beban

Harlan Grove wrote:
"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

Harlan,


Firstly, there is one bug in your function.
Your outer loop for copying the columns is now:
For j = 1 To cu
but this should be
For j = 1 To cu + (1 - cl)
Otherwise it will miss out 1 cycle with 0-based arrays.
I had made a similar mistake when redimming the marking array, as Alan
pointed out.
Secondly, I find the speed difference less, about 1 percent.
Again this will depend on the array of course.
Thirdly, there is one way to speed this function up and that is to retain
the row in the column where
the first data was found. This means you can start copying from this row on
and avoid copying empty
elements.

This is what I have now:


Function DeleteEmptyArrayColumns2(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 Variant
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 non-empty columns
'also keeps track of the first row in that column that has data
'elements will be empty at start, but will:
'get a zero if the first row has data in an 0-based array
'get a 1 if first row has data in a 1-based array
'---------------------------------------------------------------
ReDim markingArray(LB2 To UB2) As Variant

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

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

If lDataCount = 0 Or lDataCount = UB2 + (1 - LB2) Then
'only empty columns found or no empty columns found,
'so just return the original array and exit
'--------------------------------------------------
DeleteEmptyArrayColumns2 = 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 Not markingArray(c) = "" Then
'non-empty column so copy to arr2
'start copying at the first row with data
'----------------------------------------
For i = markingArray(c) To UB1
arr2(i, lGetCopyCol) = arr(i, c)
Next
'set next column to copy to
'--------------------------
lGetCopyCol = lGetCopyCol + 1
End If
Next

DeleteEmptyArrayColumns2 = arr2

End Function

Just one question.
I noticed you use very short variables, which makes reading the function
more difficult.
Is this just a personal style or would there be some (very small) speed
advantage in doing this?
My guess is not as I would think that it gets compiled (or should I say made
into p-code?) the same.


RBS


"Harlan Grove" wrote in message
...
"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

"Alan Beban" wrote...
I believe that Harlan Grove's function below, as well as Bart
Smissaert's last posted one, has a problem with 0-based arrays. I think
the problem resides, in Harlan Grove's, in

n = cu - cl + 1

You're right about a bug existing, but wrong about its cause.

This statement is not an error. Even for 0-based arrays, the number of
elements in any dimension is

ubound - lbound + 1

a(0 To 5) has 6 elements, ubound - lbound + 1 = 5 - 0 + 1 = 6
a(1 To 5) has 5 elements, ubound - lbound + 1 = 5 - 1 + 1 = 5
a(-10 To 10) has 21 elements, ubound - lbound + 1 = 10 - (-10) + 1 = 21
a(0 To 0) has 1 element, ubound - lbound + 1 = 0 - 0 + 1 = 1

Need I go on?

but the fix wasn't obvious to me.

Because you misdiagnosed the problem.

Harlan Grove wrote:
....
Function deca2(ByRef a As Variant) As Variant
....
n = cl
For j = 1 To cu
k = ne(j) '** use the stored j_th nonempty column index
....

This is where the bug is. k shouldn't be reused as a variable, but should be
used as the iteration bound instead of cu.


Function deca2(ByRef a As Variant) As Variant
'**!!** rev 1: fixed error in final loop over rv columns

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

'**!!** no reason to screw around with cu
ReDim rv(rl To ru, cl To cl + k - 1)

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

deca2 = rv
End Function

Harlan Grove wrote:
"Alan Beban" wrote...

I believe that Harlan Grove's function below, as well as Bart
Smissaert's last posted one, has a problem with 0-based arrays. I think
the problem resides, in Harlan Grove's, in

n = cu - cl + 1


You're right about a bug existing, but wrong about its cause.

This statement is not an error. Even for 0-based arrays, the number of
elements in any dimension is

ubound - lbound + 1

a(0 To 5) has 6 elements, ubound - lbound + 1 = 5 - 0 + 1 = 6
a(1 To 5) has 5 elements, ubound - lbound + 1 = 5 - 1 + 1 = 5
a(-10 To 10) has 21 elements, ubound - lbound + 1 = 10 - (-10) + 1 = 21
a(0 To 0) has 1 element, ubound - lbound + 1 = 0 - 0 + 1 = 1

Need I go on?

Only if you think that by ranting on you'll distract us from the fact
that you're being marvelously pompous about having provided the buggy
code in the first place, along with a questionable claim about a 10%
speed advantage.

Alan Beban

"Alan Beban" wrote...
Harlan Grove wrote:
....
Need I go on?

Only if you think that by ranting on you'll distract us from the fact
that you're being marvelously pompous about having provided the buggy
code in the first place, along with a questionable claim about a 10%
speed advantage.

Apparently I did need to go on because you just don't recognize a basic
identity when you see one.

As for buggy code, are you claiming you've never posted any buggy code here?
Want me to provide some google urls pointing out a few? Bugs happen.

Finally, you can test execution times for mine, the OPs and anything your
little mind can dream up too. After more testing, it seems the timing
difference depends on the number of columns in the original array and the
number of blank columns. If there are no blank columns, my udf is slower
than the OP's (not a case I had tested before), if they're all but one
blank, mine is more than 10% faster. But don't take my word for it, test it.

If you still haven't figured out how to benchmark, here's my test harness.
Note that I changed the OP's function name and incorporated his/her 0-based
array fix.


Option Explicit


Function deca1(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 + (1 - LB2) Then
'only empty columns found or no empty columns found,
'so just return the original array and exit
'--------------------------------------------------
deca1 = 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

deca1 = arr2

End Function


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)

k = 0
For j = cl To cu
For i = rl To ru
If a(i, j) Like "*[^ ]*" Then
k = k + 1
ne(k) = j
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
ReDim rv(rl To ru, cl To cu)

For j = 1 To k
n = ne(j)
For i = rl To ru
rv(i, cl) = a(i, n)
Next i
cl = cl + 1
Next j

deca2 = rv
End Function


Sub testem()
Const MAXITER As Long = 10000

Dim a As Variant, b As Variant
Dim inct As Double, cumt As Double, n As Long

a = mkfoo(10, 20, 12)

cumt = 0
For n = 1 To MAXITER
inct = Timer
b = deca1(a)
cumt = cumt + Timer - inct
Erase b
Next n
Debug.Print "deca1: " & Format(cumt, "0.00")

cumt = 0
For n = 1 To MAXITER
inct = Timer
b = deca2(a)
cumt = cumt + Timer - inct
Erase b
Next n
Debug.Print "deca2: " & Format(cumt, "0.00")

Debug.Print String(30, "-")
End Sub


Function mkfoo(rs As Long, cs As Long, n As Long) As Variant
Dim i As Long, j As Long
Dim rv As Variant

ReDim rv(0 To rs - 1, 0 To cs - 1)

For i = 0 To rs - 1
For j = 0 To cs - 1
rv(i, j) = i & " " & j
Next j
Next i

If n cs Then n = cs - 1

Do While n 0
j = Int(12 * Rnd)
For i = 0 To rs - 1
rv(i, j) = ""
Next i
n = n - 1
Loop

mkfoo = rv
End Function

The arrays I am dealing with usually have no or few empty columns and that
is what I tested with. This is probably why I didn't get the 10% speed
improvement.
What does make a difference though is to retain the row numbers of the rows
where
the first data is found as shown in the function I posted 20/8/04. As this
number
is available at no extra cost it might as well be used.

RBS


"Harlan Grove" wrote in message
...
"Alan Beban" wrote...
Harlan Grove wrote:
...
Need I go on?

Only if you think that by ranting on you'll distract us from the fact
that you're being marvelously pompous about having provided the buggy
code in the first place, along with a questionable claim about a 10%
speed advantage.

Apparently I did need to go on because you just don't recognize a basic
identity when you see one.

As for buggy code, are you claiming you've never posted any buggy code
here?
Want me to provide some google urls pointing out a few? Bugs happen.

Finally, you can test execution times for mine, the OPs and anything your
little mind can dream up too. After more testing, it seems the timing
difference depends on the number of columns in the original array and the
number of blank columns. If there are no blank columns, my udf is slower
than the OP's (not a case I had tested before), if they're all but one
blank, mine is more than 10% faster. But don't take my word for it, test
it.

If you still haven't figured out how to benchmark, here's my test harness.
Note that I changed the OP's function name and incorporated his/her
0-based
array fix.


Option Explicit


Function deca1(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 + (1 - LB2) Then
'only empty columns found or no empty columns found,
'so just return the original array and exit
'--------------------------------------------------
deca1 = 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

deca1 = arr2

End Function


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)

k = 0
For j = cl To cu
For i = rl To ru
If a(i, j) Like "*[^ ]*" Then
k = k + 1
ne(k) = j
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
ReDim rv(rl To ru, cl To cu)

For j = 1 To k
n = ne(j)
For i = rl To ru
rv(i, cl) = a(i, n)
Next i
cl = cl + 1
Next j

deca2 = rv
End Function


Sub testem()
Const MAXITER As Long = 10000

Dim a As Variant, b As Variant
Dim inct As Double, cumt As Double, n As Long

a = mkfoo(10, 20, 12)

cumt = 0
For n = 1 To MAXITER
inct = Timer
b = deca1(a)
cumt = cumt + Timer - inct
Erase b
Next n
Debug.Print "deca1: " & Format(cumt, "0.00")

cumt = 0
For n = 1 To MAXITER
inct = Timer
b = deca2(a)
cumt = cumt + Timer - inct
Erase b
Next n
Debug.Print "deca2: " & Format(cumt, "0.00")

Debug.Print String(30, "-")
End Sub


Function mkfoo(rs As Long, cs As Long, n As Long) As Variant
Dim i As Long, j As Long
Dim rv As Variant

ReDim rv(0 To rs - 1, 0 To cs - 1)

For i = 0 To rs - 1
For j = 0 To cs - 1
rv(i, j) = i & " " & j
Next j
Next i

If n cs Then n = cs - 1

Do While n 0
j = Int(12 * Rnd)
For i = 0 To rs - 1
rv(i, j) = ""
Next i
n = n - 1
Loop

mkfoo = rv
End Function

Harlan Grove wrote:

"Alan Beban" wrote...

Harlan Grove wrote:

...

Need I go on?

Only if you think that by ranting on you'll distract us from the fact
that you're being marvelously pompous about having provided the buggy
code in the first place, along with a questionable claim about a 10%
speed advantage.
. . .
As for buggy code, are you claiming you've never posted any buggy code here?

No, not at all. Just that *you're* overly pompous about it, even for
you, when *you* do.

Alan Beban

Harlan Grove wrote:
...
As for buggy code, are you claiming you've never posted any buggy code here?
Want me to provide some google urls pointing out a few?
. . .

Hey, if it's important to you, knock yourself out.

Alan Beban