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?

 

[SamTYler]

MC,

Spent a little time on my last suggestion above, and with a little more help from the board members got it working, but only with Option Base 1

Sub Test()
Dim arr_1d
Dim arr_2d() As Long
Dim arr3             'To test reading arr_1d
Dim j As Long        'Loop counter
Dim k As Long        'Loop counter
Dim l As Long        'Holds Ubound(arr_1d) for next loop
Dim m As Long        'Loop counter
Dim Timer1 As Long   'Loop start time

'Load arr_1d
Timer1 = Timer
For m = 1 To 1000
    ReDim arr_2d(10, 10)
    For j = LBound(arr_2d, 1) To UBound(arr_2d, 1)
      For k = LBound(arr_2d, 2) To UBound(arr_2d, 2)
        arr_2d(j, k) = l + (j * k)
      Next k
    Next j

'This section only happens on the first time thru
   On Error Resume Next
   If UBound(arr_1d) < 1 Then
      ReDim arr_1d(UBound(arr_2d, 1) * UBound(arr_2d, 2))
      'On Error GoTo 0 'might be faster
      GoTo Skipped 'the first time thru
   End If
   
'Must skip this line only the first time thru
   ReDim Preserve arr_1d(l + UBound(arr_2d, 1) * UBound(arr_2d, 2))
Skipped:
   For j = LBound(arr_2d, 1) To UBound(arr_2d, 1)
      For k = LBound(arr_2d, 2) To UBound(arr_2d, 2)
        arr_1d(l + (j * k)) = arr_2d(j, k)
      Next k
   Next j

l = UBound(arr_1d) 'Carry forward to next "m" loop
Next m
MsgBox (m - 1 & " m Loops took" & Chr(13) _
        & Timer - Timer1 & " Seconds")

'Read arr_1d
ReDim arr3(UBound(arr_1d))
Timer1 = Timer  'reset start time

For j = 1 To UBound(arr3)
   arr3(j) = arr_1d(j)
Next j

MsgBox ("Reading " & j - 1 & " values from" & Chr(13) _
        & "arr_1d took " & Timer - Timer1 & " Seconds")
                                              
End Sub

 

[mountainclimber11]

Thanks Sam! Unfortunately I don't have time to convert any more of these into something I can use and time. If you put it in this form so I can quickly use it, I will time it and compare it to the fastest solution so far and let you know:

my1Darray = SamsFunction(ActiveWorkbook.Name, ActiveSheet.Index)
'it takes the 1 to n columns of unknown length and turns it into a 1d array.
 
msgbox my1Darray(idx)

I would be interested in timing it and using it if is fastest. Either way, thanks for your help. Your suggests led to the fastest solution so far!

MC,

Spent a little time on my last suggestion above, and with a little more help from the board members got it working, but only with Option Base 1

Sub Test()
Dim arr_1d
Dim arr_2d() As Long
Dim arr3             'To test reading arr_1d
Dim j As Long        'Loop counter
Dim k As Long        'Loop counter
Dim l As Long        'Holds Ubound(arr_1d) for next loop
Dim m As Long        'Loop counter
Dim Timer1 As Long   'Loop start time
 
'Load arr_1d
Timer1 = Timer
For m = 1 To 1000
  ReDim arr_2d(10, 10)
  For j = LBound(arr_2d, 1) To UBound(arr_2d, 1)
    For k = LBound(arr_2d, 2) To UBound(arr_2d, 2)
      arr_2d(j, k) = l + (j * k)
    Next k
  Next j
 
'This section only happens on the first time thru
 On Error Resume Next
 If UBound(arr_1d) < 1 Then
    ReDim arr_1d(UBound(arr_2d, 1) * UBound(arr_2d, 2))
    'On Error GoTo 0 'might be faster
    GoTo Skipped 'the first time thru
 End If
 
'Must skip this line only the first time thru
 ReDim Preserve arr_1d(l + UBound(arr_2d, 1) * UBound(arr_2d, 2))
Skipped:
 For j = LBound(arr_2d, 1) To UBound(arr_2d, 1)
    For k = LBound(arr_2d, 2) To UBound(arr_2d, 2)
      arr_1d(l + (j * k)) = arr_2d(j, k)
    Next k
 Next j
 
l = UBound(arr_1d) 'Carry forward to next "m" loop
Next m
MsgBox (m - 1 & " m Loops took" & Chr(13) _
      & Timer - Timer1 & " Seconds")
 
'Read arr_1d
ReDim arr3(UBound(arr_1d))
Timer1 = Timer  'reset start time
 
For j = 1 To UBound(arr3)
 arr3(j) = arr_1d(j)
Next j
 
MsgBox ("Reading " & j - 1 & " values from" & Chr(13) _
      & "arr_1d took " & Timer - Timer1 & " Seconds")
 
End Sub

 

[white_flag]

it is possible a bit of help/ the situation

I have to initialized an listview from dynamic range. but in my case the transpose it is not going so my code:

Function FillRecords() As Collection
    
    Dim colRecords As Collection
    Dim clsRecord As CRecord
    Dim vaNames As Variant, vaDepts As Variant
    Dim i As Long, j As Long
    
   
    'vaNames = Application.Transpose(Sheets("sheet1").Range("name").Value) - not going
    'vaNames = Array("45", "55", "55", "55", "55")
     vaDepts = Array("45", "55", "55", "55", "55")
    
    Set colRecords = New Collection
    
    For i = 1 To 5
        Set clsRecord = New CRecord
        clsRecord.Name = vaNames(i - 1)
        clsRecord.Name = vaDepts(i - 1)
        colRecords.Add clsRecord, CStr(i)
    Next i
    
    Set FillRecords = colRecords
    
End Function

please if it is possible to help me.

 

[SamTYler]

MountainClimber,

Option Base 1
Function SamsFunction(MatrixSheet As Worksheet) As Variant
'Assumes that all columns except last are of equal length
' If last column has fewer values than others, then the
' last few items in my1Darray will be empty. The use of LastRow
' eliminates a few FLOPS Per iteration over using UBound(arrCol).
'
'If it is critical that the last few items in my1Darray not be read
' then you can test it by 'If my1Darray(n) = "".' Testing in this
' function for "j = LastCol" then finding LastRow of LastCol
' will add some FLOPS to every iteration (Column)
'
'To use:
'my1Darray = SamsFunction(Workbooks("MyBook").Sheets(n)) where n is the sheet index
'
'There is NO error checking!
Dim arr_1d()         'loaded from arrRowCol
Dim arrTable()          'Holds the working range's values
Dim LastRow As Long  'Loop counter
Dim LastCol As Long  'Loop counter
Dim ub1d As Long     'Holds Ubound(arr_1d) for next loop
Dim j As Long        'Loop counter (Cols)
Dim k As Long        'Loop counter (Rows)
Dim m As Long        'Loop counter (arr_1d)
'Find Last Col and Last Row
   With MatrixSheet
      LastCol = Range("A1").End(xlToRight).Column
      LastRow = Range("A1").End(xlDown).Row
   End With
'Size arrCol and arr_1d
   ReDim arrTable(LastRow, LastCol)
   ReDim arr_1d(LastRow * LastCol)
'Load arrTable with values
   arrTable = Range("A1", Cells(LastRow, LastCol))
 
'Load arr_1d with arrTable
   m = 1 'Initialize m
   For j = 1 To LastCol
      For k = 1 To LastRow
         arr_1d(m) = arrTable(k, j)
         m = m + 1
      Next k
   Next j
 
SamsFunction = arr_1d
End Function
</PRE>

 

[white_flag]

thank you. but I used this solution it is feeting for my needs:

    Dim LR As Long, LC As Long
    Dim cell As Range
    
    With Sheets("Sheet1")
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
 
        For Each cell In Range("A3", Cells(3, LC))
            .ListItems.Add , , cell
            ListView1_ItemClick .ListItems(.SelectedItem.Index) 'fill edit controls
        Next cell