Define VBA array from excel range

[dcase]

Hi All,

Have put together a macro to loop through filtering a list then printing the filtered list:

Private Sub PrintAllSheets_Click()

CustNo = Array("1010", "1016", "1017", "1018")
For i = 0 To 3
Selection.AutoFilter Field:=15, Criteria1:=CustNo(i)
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Next i

End Sub

Rather than defining the array manually, I would like to populate it from the following range: Sheets("Affected Customers").Range("A1:A4"). Have tried replacing Array("1010", "1016", "1017", "1018") with Array(Sheets("Affected Customers").Range("A1:A4")) but doesn't work.

Any ideas?

 

[Norie]

Sam

That's not quite right.

You are only allowed to redim the last dimension of an array when using the Preserve keyword.

You also can't redim an array when you've specified the dimensions when declaring it.

 

[SamTYler]

Norie,

Do you know what Pseudocode means?

 

[Norie]

Sam

Yes I do - I was just trying to explain a couple of things about arrays as they are used in Excel VBA.

I was in no way being critical of what you posted.

In fact I took your psuedcode turned it into 'real' code and checked things out before I posted.

The 2nd thing about not being able to redimension an already dimensioned I didn't actually know about.

I also did this little test to see if your idea would work.

Dim arr() As Double
Dim I As Long
Dim J As Long
    ReDim arr(1, 10000)
    For I = LBound(arr, 1) To UBound(arr, 1)
        For J = LBound(arr, 2) To UBound(arr, 2)
            arr(I, J) = Rnd() * 100
        Next J
    Next I
 
    ReDim Preserve arr(200000)

I'm afraid VBA didn't like the 2nd Redim.

 

[SamTYler]

I was thinking that MountainClimber would only be redimming the 1 dimension array, so your idea with this mod might work

Pseudocode:

Dim 1d_arr()
Dim J As Long
    ReDim 1d_arr(10000)
    For J = LBound(1d_arr) To UBound(1d_arr)
            arr(J) = Rnd() * 100
    Next J
    ReDim Preserve 1d_arr(200000)

I wonder if there is a limit on array size, other than the limit of the Long index

 

[JackBean]

tusharm suggests that his approach is probably fastest or most efficient, but mountainclimber11 likes the idea of building the one dimensional data array.

These two approaches can be combined in the building of the 1D array.
This is the first time I have used properties and I will look for a way to use tusharm's approach in one of my files.

The code below could probably be put on a loop for each new range of 2D data. Blanks make for an exit from the 2D array. Of course you only have to Redim Preserve only once for each additional 2D array.

Option Explicit
Dim lCx As Long, lRx As Long, lWx As Long, lXx As Long, lYx As Long, lZx As Long
Dim sAry As String
Dim vArr As Variant
Dim vTbl As Variant
 
Sub Initialize(Cell1 As Range)
vArr = Cell1.CurrentRegion.Value
lCx = UBound(vArr, 2)
lRx = UBound(vArr, 1)
End Sub
 
Property Get MyArr(I)
MyArr = vArr((I - 1) Mod lRx + 1, ((I - 1) \ lRx) + 1)
End Property
 
Property Let MyArr(I, uVal)
vArr((I - 1) Mod lRx + 1, ((I - 1) \ lRx) + 1) = uVal
End Property
 
Sub TestProps()
Initialize Cells(1, 1)
lZx = lCx * lRx
sAry = ""
ReDim vTbl(1 To lZx)
For lYx = 1 To lZx
    If MyArr(lYx)<> "" Then
        vTbl(lYx) = MyArr(lYx)
    Else
        lYx = lYx - 1
        Exit For
    End If
Next lYx
Initialize Cells(7, 1)
lXx = lYx
lZx = lCx * lRx
ReDim Preserve vTbl(1 To lYx + lZx)
For lYx = 1 To lZx
    If MyArr(lYx)<> "" Then
        vTbl(lXx + lYx) = MyArr(lYx)
    Else
        lYx = lYx - 1
        Exit For
    End If
Next lYx
For lWx = 1 To lXx + lYx
    Debug.Print vTbl(lWx)
    sAry = sAry & ", " & vTbl(lWx)
Next lWx
MyArr(9) = 45
MsgBox sAry & ", " & MyArr(9)
End Sub

DATA:

Excel Workbook
	A	B	C
1	a	6
2	2	7
3	c
4	4	9
5	5
6
7	11	14	17
8	12	15
9	13	16	19
Sheet1

Excel 2003

Result of debug.print:
a
2
c
4
5
6
7
11
12
13
14
15
16
17

 

[mountainclimber11]

OK...Sam I couldn't get your last one to work...probably my issue but I played with it for about 30 minutes and no dice.

JackBean's is about 25% slower than the last one I built (from Sam's ideas).

Here is how I used and tested Jack's:

Option Explicit
Dim lCx As Long, lRx As Long, lWx As Long, lXx As Long, lYx As Long, lZx As Long
Dim sAry As String
Dim vArr As Variant
Dim vTbl As Variant
 
Sub Initialize(Cell1 As Range)
vArr = Cell1.CurrentRegion.Value
lCx = UBound(vArr, 2)
lRx = UBound(vArr, 1)
End Sub
 
Property Get MyArr(i)
MyArr = vArr((i - 1) Mod lRx + 1, ((i - 1) \ lRx) + 1)
End Property
 
Property Let MyArr(i, uVal)
vArr((i - 1) Mod lRx + 1, ((i - 1) \ lRx) + 1) = uVal
End Property
 
Function TableToArray_v3(wb As String, sht As Integer)
Initialize Workbooks(wb).Sheets(sht).Cells(1, 3)
lZx = lCx * lRx
sAry = ""
ReDim vTbl(1 To lZx)
For lYx = 1 To lZx
    If MyArr(lYx) <> "" Then
        vTbl(lYx) = MyArr(lYx)
    Else
        lYx = lYx - 1
        Exit For
    End If
Next lYx
TableToArray_v3 = vTbl
'MsgBox vTbl(1)
End Function
Sub tester()
Dim StartTime As Date
Dim EndTime As Date
Dim test() As Variant
Dim i As Integer
StartTime = Timer
 
For i = 1 To 1000
test = TableToArray_v3(ActiveWorkbook.Name, 1)
Next i
EndTime = Timer
 
Debug.Print Format(EndTime - StartTime, "000.000")
 
MsgBox test(1465)
End Sub

Here is how I used and tested the faster one:

Sub tester()
Dim StartTime As Date
Dim EndTime As Date
Dim test As Variant
Dim i As Integer
StartTime = Timer
For i = 1 To 1000
test = TableToArray(ActiveWorkbook.Name, 1)
Next i
EndTime = Timer
 
Debug.Print Format(EndTime - StartTime, "000.000")
MsgBox test(1465)
End Sub
Function TableToArray(wb As String, sht As Integer) As String()
With Workbooks(wb).Sheets(sht)
    Dim d2Array As Variant
    d2Array = .Range("C1", FindlastCell())
    ReDim d1Array(Application.CountA(.Cells)) As String
    'MsgBox UBound(d1Array)
    Dim idx As Integer
    'MsgBox LastRowInOneColumn(3, wb, sht) & " rows"
    For j = 1 To Application.CountA(.Columns)
        For k = 1 To LastRowInOneColumn(3, wb, sht)
        idx = idx + 1
        If d2Array(k, j) = "" Then
            GoTo done
        End If
        d1Array(idx) = d2Array(k, j)
        'MsgBox idx & " =idx k= " & k & " j= " & j
        Next k
    Next j
done:
End With
TableToArray = d1Array
End Function
 
Function LastRowInOneColumn(xcol As Long, wb As String, sht As Integer) As Long
'Find the last used row in a Column: column A in this example
    Dim xLastRow As Long
    With Workbooks(wb).Sheets(sht)
        xLastRow = .Cells(.Rows.count, xcol).End(xlUp).row
    End With
 
LastRowInOneColumn = xLastRow
End Function
Function FindlastCell() As Range
Dim theLastColumn As Integer
Dim theLastRow As Long
Dim theLastCell As Range
With ActiveSheet
    If WorksheetFunction.CountA(Cells) > 0 Then
        'Search for any entry, by searching backwards by Rows.
        theLastRow = .Cells.Find(What:="*", after:=[a1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
        'Search for any entry, by searching backwards by Columns.
                theLastColumn = .Cells.Find(What:="*", after:=[a1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                Set FindlastCell = .Range(Cells(theLastRow, theLastColumn).Address)
    End If
 
End With
End Function

Thank you everyone for your help! ...Really!

 

[mountainclimber11]

Tusham...great code! But unfortunately the "unless" that you mention makes a huge difference so I couldn't use your idea...

Unless there is reason to be believe that the speed of the calculation in the 'data abstraction layer' * millions > speed of reorganizing the data * thousands, I would go with the easier approach, i.e., the DAL.

 

[mountainclimber11]

With one change in the faster one:

For j = 1 To .UsedRange.Columns.count

Because it wouldn't count just one column.

OK...Sam I couldn't get your last one to work...probably my issue but I played with it for about 30 minutes and no dice.

JackBean's is about 25% slower than the last one I built (from Sam's ideas).

Here is how I used and tested Jack's:

Option Explicit
Dim lCx As Long, lRx As Long, lWx As Long, lXx As Long, lYx As Long, lZx As Long
Dim sAry As String
Dim vArr As Variant
Dim vTbl As Variant
 
Sub Initialize(Cell1 As Range)
vArr = Cell1.CurrentRegion.Value
lCx = UBound(vArr, 2)
lRx = UBound(vArr, 1)
End Sub
 
Property Get MyArr(i)
MyArr = vArr((i - 1) Mod lRx + 1, ((i - 1) \ lRx) + 1)
End Property
 
Property Let MyArr(i, uVal)
vArr((i - 1) Mod lRx + 1, ((i - 1) \ lRx) + 1) = uVal
End Property
 
Function TableToArray_v3(wb As String, sht As Integer)
Initialize Workbooks(wb).Sheets(sht).Cells(1, 3)
lZx = lCx * lRx
sAry = ""
ReDim vTbl(1 To lZx)
For lYx = 1 To lZx
    If MyArr(lYx) <> "" Then
        vTbl(lYx) = MyArr(lYx)
    Else
        lYx = lYx - 1
        Exit For
    End If
Next lYx
TableToArray_v3 = vTbl
'MsgBox vTbl(1)
End Function
Sub tester()
Dim StartTime As Date
Dim EndTime As Date
Dim test() As Variant
Dim i As Integer
StartTime = Timer
 
For i = 1 To 1000
test = TableToArray_v3(ActiveWorkbook.Name, 1)
Next i
EndTime = Timer
 
Debug.Print Format(EndTime - StartTime, "000.000")
 
MsgBox test(1465)
End Sub

Here is how I used and tested the faster one:

Sub tester()
Dim StartTime As Date
Dim EndTime As Date
Dim test As Variant
Dim i As Integer
StartTime = Timer
For i = 1 To 1000
test = TableToArray(ActiveWorkbook.Name, 1)
Next i
EndTime = Timer
 
Debug.Print Format(EndTime - StartTime, "000.000")
MsgBox test(1465)
End Sub
Function TableToArray(wb As String, sht As Integer) As String()
With Workbooks(wb).Sheets(sht)
    Dim d2Array As Variant
    d2Array = .Range("C1", FindlastCell())
    ReDim d1Array(Application.CountA(.Cells)) As String
    'MsgBox UBound(d1Array)
    Dim idx As Integer
    'MsgBox LastRowInOneColumn(3, wb, sht) & " rows"
    For j = 1 To Application.CountA(.Columns)
        For k = 1 To LastRowInOneColumn(3, wb, sht)
        idx = idx + 1
        If d2Array(k, j) = "" Then
            GoTo done
        End If
        d1Array(idx) = d2Array(k, j)
        'MsgBox idx & " =idx k= " & k & " j= " & j
        Next k
    Next j
done:
End With
TableToArray = d1Array
End Function
 
Function LastRowInOneColumn(xcol As Long, wb As String, sht As Integer) As Long
'Find the last used row in a Column: column A in this example
    Dim xLastRow As Long
    With Workbooks(wb).Sheets(sht)
        xLastRow = .Cells(.Rows.count, xcol).End(xlUp).row
    End With
 
LastRowInOneColumn = xLastRow
End Function
Function FindlastCell() As Range
Dim theLastColumn As Integer
Dim theLastRow As Long
Dim theLastCell As Range
With ActiveSheet
    If WorksheetFunction.CountA(Cells) > 0 Then
        'Search for any entry, by searching backwards by Rows.
        theLastRow = .Cells.Find(What:="*", after:=[a1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
        'Search for any entry, by searching backwards by Columns.
                theLastColumn = .Cells.Find(What:="*", after:=[a1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                Set FindlastCell = .Range(Cells(theLastRow, theLastColumn).Address)
    End If
 
End With
End Function

Thank you everyone for your help! ...Really!

 

[JackBean]

Since the property is being used twice, it may run faster if it is used only once in the loop, so change:

For lYx = 1 To lZx
    If MyArr(lYx) <> "" Then
        vTbl(lYx) = MyArr(lYx)
    Else
        lYx = lYx - 1
        Exit For
    End If
Next lYx

To:
(where vQx is a variant variable)

For lYx = 1 To lZx
    vQx = MyArr(lYx)
    If vQx <> "" Then
        vTbl(lYx) = vQx
    Else
        lYx = lYx - 1
        Exit For
    End If
Next lYx

 

[mountainclimber11]

JackBean-

Humm...my Timer stopped working and causes a compile error now. Anyone know whats up with that?

Anyway, I changed timer systems on this one but the combination method (JackBean's using Tusharm's Properties) is still a a little slower over all 4 runs:

Fastest....Run Duration: 00:00:30, Stop Time: 4/13/2010 12:33:08 AM
Props....Run Duration: 00:00:32, Stop Time: 4/13/2010 12:33:59 AM
Fastest....Run Duration: 00:00:30, Stop Time: 4/13/2010 12:34:43 AM
Props....Run Duration: 00:00:32, Stop Time: 4/13/2010 12:35:26 AM

Jack, it is faster than it was, but still not fastest...

Here is the code I used for JackBean's slighly slower way...including testing method...if anyone wants to improve it or point out a mistake that I made: (see previous posts for the faster one)

Dim lCx As Long, lRx As Long, lWx As Long, lXx As Long, lYx As Long, lZx As Long
Dim sAry As String
Dim vArr As Variant
Dim vTbl As Variant
Sub Timers()
Dim t As Date
Dim test() As Variant
t = Now()
Dim i As Long
For i = 1 To 10000
 
test = TableToArray_v3(ActiveWorkbook.Name, 1)
 
Next i
 
Debug.Print "Props....Run Duration: "; Format(Now() - t, "hh:mm:ss") & ", Stop Time: " & Now
MsgBox test(1916)
End Sub
 
Sub Initialize(Cell1 As Range)
vArr = Cell1.CurrentRegion.Value
lCx = UBound(vArr, 2)
lRx = UBound(vArr, 1)
End Sub
 
Property Get MyArr(i)
MyArr = vArr((i - 1) Mod lRx + 1, ((i - 1) \ lRx) + 1)
End Property
 
Property Let MyArr(i, uVal)
vArr((i - 1) Mod lRx + 1, ((i - 1) \ lRx) + 1) = uVal
End Property
 
Function TableToArray_v3(wb As String, sht As Integer) As Variant()
Initialize Workbooks(wb).Sheets(sht).Cells(1, 3)
lZx = lCx * lRx
sAry = ""
ReDim vTbl(1 To lZx)
For lYx = 1 To lZx
    vQx = MyArr(lYx)
    If vQx <> "" Then
        vTbl(lYx) = vQx
    Else
        lYx = lYx - 1
        Exit For
    End If
Next lYx
TableToArray_v3 = vTbl

End Function