I'm trying to loop through email messages in Outlook, scrap unique ID numbers and concatenate them as one string.
Each message contains several different IDs that are multiplied across the email, like these:
ID 1111, ID 2222
ID 1111, ID 33333, ID 2222
ID 1111, ID 2222, ID 444, ID 33333
ID 2222, ID 1111
Then expected result would be (sorted):
ID 444, ID 1111, ID 2222, ID 33333
Here is my code.
Sub Scrap_IDs()
Dim olApp As Outlook.Application: Set olApp = New Outlook.Application
Dim olFolder As MAPIFolder: Set olFolder = olApp.Session.GetDefaultFolder(olFolderInbox).Folders("Folder_name")
Dim olMail As Variant: For Each olMail In olFolder.Items
Dim mBody As String: mBody = olMail.Body
With olMail
' Scrap all IDs using regex
With New RegExp
.Global = True
.Pattern = "ID[ \d]+"
Dim MatchID As Object: For Each MatchID In .Execute(mBody)
Dim i As Long: Dim arrMatchID(): ReDim Preserve arrMatchID(i)
arrMatchID(i) = MatchID.Value
i = i + 1
Next
End With
' Remove duplicates from array
Dim RemArrDups As Variant: RemArrDups = WorksheetFunction.Sort(WorksheetFunction.Unique(WorksheetFunction.Transpose(arrMatchID)))
' Concatenate array items
Dim IDs As String: IDs = Join(RemArrDups, ", ")
End With
Next
End Sub
The line related to concatenation gives run-time error 5 "Invalid procedure call or argument". Why is that?
It works if I use the Join function on arrMatchID instead of RemArrDups, but this way the values won't be unique.
Using Microsoft 365's UNIQUE and SORT in VBA
' This is a 1D array, a single row.
Dim arrMatchId(): arrMatchId = Array( _
"ID 667", "ID 3", "ID 1111", "ID 2222", "ID 3", "ID 44", "ID 667")
' Remove duplicates and sort the array.
' Keep it a single row (don't transpose). Use 'True' as the parameters
' for the 'col' arguments of both functions.
Dim RemArrDups(): RemArrDups _
= Application.Sort(Application.Unique(arrMatchId, True), , , True)
' Join.
Dim IDs As String: IDs = Join(RemArrDups, ", ")
Debug.Print IDs
Related
MY APOLOGIES: the code snipet below can induce in error that i work from a worksheet - I got the values in the code from a worksheet only to lighten the code. The VALUES are from an ADODB dataset that is then copied to an array. The values are to stay in memory and no worksheets are to be used to get the end result. so sorry not to have specified this from the start.
I have a 2-dimensional array and I am trying to get the MAX(VALUE) for each unique IDs
ID
VALUE
DATA
101
10
1125
101
8
2546
101
11
1889
102
5
3521
102
10
2254
103
11
3544
the end result should be a finalArr with the unique IDs:
ID
VALUE
DATA
101
11
1889
102
10
2254
103
11
3544
What I have so far:
I did manage to find the MAX in a specific dimension (Value)
Sub MX_Value()
Dim dataArr, iMax As Long, iCount As Long, tmpArr() As Integer, MyDim As Integer
Dim i As Integer
'*NOTE: Values from worksheet is an example only
'in real-life the data comes from an ADODB dataset
'so i need code that works in memory only.
dataArr = ThisWorkbook.Sheets(1).[A1:C6].Value
ReDim tmpAr(1 To UBound(dataArr))
MyDim = 2 'Desired Dimension, 1 to 2
For i = 1 To UBound(dataArr)
tmpAr(i) = dataArr(i, MyDim)
Next
iMax = WorksheetFunction.Max(tmpAr)
iCount = WorksheetFunction.Match(iMax, tmpAr, 0)
MsgBox "MAX value is in dataArr(" & iCount & ") - with data: " & dataArr(iCount, 1) & " - " & dataArr(iCount, 2) & " - " & dataArr(iCount, 3)
End Sub
but I can't figure out how to group the individual IDs to find their MAX. The only logic I can come up with would be to:
Get first ID, then add all rows with the same ID to a tempArr
Send tempArr to a Function to get the MAX and copy the MAX row to a finalArr
Go to next ID not matching the previous one and start again... [???]
Note: in the code example the data is from a worksheet, but only to simplify the code. In it's real-world application, the data in the array comes from an ADODB dataset - so everything must be done in memory
Any insights would be greatly appreciated!
You can use a dictionary to keep track of the maximum values, see example below.
This is the class module called "Record"
Public id As Integer
Public value As Integer
Public data As Integer
Here's the code for the button click I wired up on the sheet
Sub Button3_Click()
Dim dict 'Create a variable
Set dict = CreateObject("Scripting.Dictionary")
Dim dataArr() As Variant
Dim id, value, data As Integer
dataArr = Range("A2:C7").value
Dim rec As Record
For i = 1 To UBound(dataArr)
id = dataArr(i, 1)
value = dataArr(i, 2)
data = dataArr(i, 3)
If (dict.Exists(id)) Then
Set rec = dict(id)
' if value is greater, then update it in dictionary for this id
If (value > rec.value) Then
dict.Remove (rec.id)
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Else
' this is an id we haven't seen before, so add rec to dictionary
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Next
' print results
Dim result As String
For Each id In dict.Keys()
Set rec = dict(id)
result = result & "id = " & id & ", maxValue = " & rec.value & ", data = " & rec.data & vbCrLf
Next
MsgBox (result)
End Sub
Get Maximum of Each Unique Value
The dictionary will hold the unique value as its key, and the row of the highest value as the corresponding item. While looping, it will use this item to compare the values of the 2nd column and modify it accordingly. In the end, another loop will write the results to the same array which will partially be copied to the destination range.
One row of headers is assumed. If you don't want the headers, then change the sfcAddress if necessary and change For r = 1 to srCount and r = 0.
Option Explicit
Sub MaxOfUnique()
Const sName As String = "Sheet1"
Const sfcAddress As String = "A1"
Const dName As String = "Sheet1"
Const dfcAddress As String = "E1"
Const cCount As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sfcAddress)
Dim srg As Range
With sfCell.CurrentRegion
Set srg = sfCell.Resize(.Row + .Rows.Count _
- sfCell.Row, .Column + .Columns.Count - sfCell.Column)
End With
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 2 Then Exit Sub
Dim Data As Variant: Data = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 2 To srCount
If dict.Exists(Data(r, 1)) Then
If Data(r, 2) > Data(dict(Data(r, 1)), 2) Then
dict(Data(r, 1)) = r
End If
Else
dict(Data(r, 1)) = r
End If
Next r
Dim Key As Variant
r = 1
For Each Key In dict.Keys
r = r + 1
Data(r, 1) = Key
Data(r, 2) = Data(dict(Key), 2)
Data(r, 3) = Data(dict(Key), 3)
Next Key
With wb.Worksheets(dName).Range(dfcAddress).Resize(, cCount)
.Resize(r).Value = Data ' write
.Resize(.Worksheet.Rows.Count - .Row - r + 1).Offset(r).Clear ' below
End With
End Sub
I have a command button on a userform that will match strings from two textboxes with data in specific columns on a "Database" sheet, if a match is found it copies the row to another sheet.
The code works and matches data from the sheet when the matched data is the "first" in the database. Meaning, the match data can be in row 1, 2, 3, 10 but as long as NO data exist before it the match works.
Problem: Match breaks when data exists in rows above the matched criteria. I get a match return of False when it should True. When I move the data to be the "first" data it works.
Screenshots to help illustrate:
Match Criteria
--Works--
Returns True on Locals
--Breaks--
Match Fails
Returns False in Locals
I am using an array that lines up the indexes with the columns I am searching so I don't have to sort the data. But I did try and sort it and the same issue occurred. I also made sure all the cells in the range I am searching are of format "General", just in in case. I am not "seeing" what else it could be? Any help would be greatly appreciated.
Private Sub run_check_but_Click()
Const COL_STATUS As Long = 4
Dim wsData As Worksheet, wsSyn As Worksheet
Dim tRow As Long, i As Long
Dim tempList(1 To 9) As String
Dim match As Boolean
Dim rCol As Range, c As Range
Set wsData = Sheets("Database")
Set rCol = wsData.Range(wsData.Cells(3, 4), wsData.Cells(100, 4))
'Set TargetSheet and clear the previous contents
Set wsSyn = Sheets("Syn_Calc")
wsSyn.Range("A3:G" & wsSyn.Range("A" & Rows.count).End(xlUp).row + 1).ClearContents
tRow = 3
'Set an array of strings, based on the index matching the column to search for each
tempList(5) = curbase_box.Text 'Column "E" (5)
tempList(6) = dirquote_box.Text 'Column "F" (6)
For Each c In rCol.Cells
With c.EntireRow
If .Cells(COL_STATUS).Value = "Open" Then
match = False
For i = LBound(tempList) To UBound(tempList)
If tempList(i) <> "" Then
match = (.Cells(i).Text = tempList(i))
If Not match Then Exit For
End If
Next i
If match Then
'copy values from E-K
wsSyn.Cells(tRow, 1).Resize(1, 7).Value = _
.Cells(5).Resize(1, 7).Value
tRow = tRow + 1
End If
End If 'open
End With
Next c
End Sub
Expected Results: When I click on the command button it will search through the columns to match the strings in the textboxes no matter where the data is within the columns and copy the match row to another sheet.
Note: The code will only search for a match if the 4th column("D") has the status of "Open" as you saw in the code. I confirmed this works fine.
I have added some debugging lines and another loop. Have a look! Check also the output in the immediate window (Ctrl G)!
Sample output in the immediate window:
rCol.Address: $D$2:$D$9
start in $D$6
search for CHF
--- search in $E$6
--- search in $F$6
--- search in $G$6
--- search in $H$6
search for 12342
--- search in $E$6
--- search in $F$6
--- search in $G$6
--- search in $H$6
start in $D$7
search for CHF
--- search in $E$7
--- search in $F$7
--- search in $G$7
--- search in $H$7
==============> Match in $H$7
...
...
...
Database
Syn_Calc
Option Explicit
Sub test()
Dim c As Range
Dim COL_STATUS As Integer
Dim Match As Boolean
Dim i As Integer
Dim j As Integer
Dim TempList(10) As String
Dim tRow
Dim wsSyn As Worksheet
Dim wsDAta As Worksheet
Dim rCol As Range
Dim MatchRef As String
COL_STATUS = 4
Set wsDAta = Sheets("Database")
Set rCol = wsDAta.Range(wsDAta.Cells(2, 4), wsDAta.Cells(9, 4))
Debug.Print "rCol.Address: "; rCol.Address
'Set TargetSheet and clear the previous contents
Set wsSyn = Sheets("Syn_Calc")
wsSyn.Range("A3:G" & wsSyn.Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents
tRow = 3
'Set an array of strings, based on the index matching the column to search for each
TempList(5) = "CHF" 'curbase_box.Text 'Column "E" (5)
TempList(6) = "12342" 'dirquote_box.Text 'Column "F" (6)
For Each c In rCol.Cells
'Set c = Range("A2")
With c.EntireRow
If .Cells(COL_STATUS).Value = "Open" Then
Match = False
MatchRef = ""
Debug.Print
Debug.Print "start in "; c.Address
For i = LBound(TempList) To UBound(TempList)
If TempList(i) <> "" Then
Debug.Print "search for "; TempList(i)
For j = 5 To 8 'Col E to H
Debug.Print "--- search in "; .Cells(1, j).Address
Match = (.Cells(1, j).Text = TempList(i))
If Match Then
'debug: matchRef info
MatchRef = "match in " & .Cells(1, j).Address & " - Value : " & TempList(i)
Debug.Print "==============> Match in "; .Cells(1, j).Address
Exit For
End If
Next j
If Match Then Exit For
End If
Next i
If Match Then
'copy values from E-K
wsSyn.Cells(tRow, 1).Resize(1, 7).Value = _
.Cells(5).Resize(1, 7).Value
'debug: matchRef info
wsSyn.Cells(tRow, 9).Value = MatchRef
tRow = tRow + 1
End If
End If 'open
End With
Next c
End Sub
I've spent hours trying to find out how to join returned values from a named range, but the result is a
run-time error 32 - Type mismatch.
As a newbie I'm still struggling with arrays, so maybe I've overlooked some detail. Thank you for helping me out.
Example: (B1)Benzine, (B2)Diesel, (B3)Hybride -> (E1)Gasoline, (E2)Diesel, (E3)Hybrid
This is the named range:
Another example (to be more clear):
Example 2: (B1)Benzine, (B3)Hybride -> (E1)Gasoline, (E3)Hybrid
Option Explicit
Sub splitter()
Dim i As Long
Dim w As Long
'Dim oWB As Workbook
Dim oWS As Worksheet
Dim oWS9 As Worksheet
Dim rngMOTOR As Range
Dim rngMOTOR2 As Range
Dim arrMOTOR() As Variant
Dim LastRow As Long
'Set oWB = Workbooks("BRONBESTAND.xlsm")
Set oWS = Sheets("ONDERDELEN")
Set oWS9 = Sheets("MOTOR") '5 columns: 1 Short & LONG + 1 NL + 3 Languages !!!!! WARNING
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow 'Starting below headers
Set rngMOTOR = oWS.Cells(i, "M") 'MOTOR ...
Set rngMOTOR2 = oWS9.Range("MOTOR") 'MOTOR2: MOTOR - Bronbestand arrPOS = rngPOS2.Value
arrMOTOR = rngMOTOR2.Value
'*********
Dim txt As String
Dim j As Integer
Dim Splitted As Variant
Dim arrMOTORall As Variant
Dim arrMOTORsplit As Variant
Dim Motor3 As String
txt = oWS.Cells(i, "M") 'MOTOR ...
Debug.Print ("txt : ") & i & ": "; txt
If Not IsEmpty(txt) Then
Splitted = Split(txt, ", ")
For j = 0 To UBound(Splitted)
Cells(1, j + 1).Value = Splitted(j)
Debug.Print (" ---> Splitted: ") & Splitted(j)
'**** INSERT *****
For w = LBound(arrMOTOR) To UBound(arrMOTOR)
If arrMOTOR(w, 1) = Splitted(j) Then 'EX: B - Benzine
arrMOTORsplit = (arrMOTOR(w, 4)) '(arrMOTOR(y, 2)) -> 1=SHORT+LONG , 2=NL, 3=FR, 4=EN
Debug.Print (" ---> arrMOTORsplit: ") & i & ": " & arrMOTORsplit
'**** JOIN ****
arrMOTORall = Join(arrMOTORsplit, ", ")
Debug.Print ("arrMOTORall: ") & arrMOTORall
End If
Next w
Next j
End If
Next i
End Sub
Get comma separated strings for each column in named range
I didn't analyze your code, but this should work to receive the first three values joined
"Benzine, Diesel, Hybride" ' e.g. from first column
or
"Gasoline, Diesel, Hybrid" ' e.g. from the fourth column
from a named range "Motor" via the Application.Index function.
Notes
The parameter 0 in this Index function indicates to not choose a specific row, the Parameter ColNo chooses each of your columns in a Loop. A subsequent transposition allows to change the 2 dimensioned array values to a 1-dim array. The Join function needs a 1-dim array and concatenates the chosen column items therein.
Hint: The following sample code uses a fully qualified range reference assuming that you don't call the TestMe procedure from your Personal Macro Library. In the latter case you'd have to change references and workbook identification (not using ThisWorkbook!).
Example code
Option Explicit ' declaration head of your code module
Sub TestMe()
Dim v As Variant, ColNo As Long
' assign first three rows to variant 1-based 2-dim datafield array
v = ThisWorkbook.Worksheets("Motor").[Motor].Resize(3, 4) ' Named range value
' write comma separated list for each column
For ColNo = 1 To 4
Debug.Print Join(Application.Transpose(Application.Index(v, 0, ColNo)), ", ")
Next ColNo
End Sub
EDIT - Flexible Search in ANY ORDER to translate joined lists
This solution allows to return joined search words in any combination using the Application.Index function in an advanced way using row and column arrays as parameters. The main function getSplitters() creates a variant 2-dim array in only three steps without loops and redims and uses two language constants (Const DUTCH and Const ENGLISH).:
assigns data to variant 1-based 2-dim datafield array
gets only the selected rows based on comma separated string values
reduces the same array to Dutch and English columns
Calling Code
Due to your OP the calling code anylyzes all comma separated strings in Column M in your sheet "ONDERDELEN" as far as there are values in column A. This is made by passing these found string values to the main function getSplitters with an innovative approach to get results in only three steps without Loops (see function code below).
Translation is based on values in the named range Motor "B1:E4" in sheet "Motor" where rows comprise different sort of fuel with neighbouring columns for different languages (starting with Dutch in the first column and English in the fourth col).
Note that using VBA it is faster to loop through an array to get values than through a range.
Option Explicit ' declaration head of your code module
Const DUTCH As Integer = 1
Const ENGLISH As Integer = 4
Sub TranslateAnyFuelCombination()
' Purpose: returns comma separated lists in column "M" and translates from Dutch to English
' Example: "Benzine, Hybride, Diesel" (Dutch) gets to "Gasoline, Hybrid, Diesel" in English
Dim s As String
Dim oWS As Worksheet, i&, LastRow&, vMOTOR As Variant
Set oWS = Thisworkbook.Worksheets("ONDERDELEN") ' fully qualified reference
' Get last row of wanted data
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
vMOTOR = oWS.Range("M1:M" & LastRow)
For i = 2 To LastRow 'Starting below headers
Debug.Print getSplitters(vMOTOR(i, 1))
Next i
End Sub
Main function
Function getSplitters(ByVal sRows As String) As String
Dim i As Long, j As Long
Dim v As Variant, a As Variant
' [0] analyze selected rows string, e.g. "Benzine, Hybride, Diesel"
a = getRowAr(sRows) ' -> assign 1-dim Rows Array(1, 3, 2)
' [1] assign data to variant 1-based 2-dim datafield array
v = Application.Transpose(ThisWorkbook.Worksheets("Motor").[Motor]) ' Named range value
' [2] get only selected rows, e.g. 1st, 3rd and 2nd -> in free order (!) Benzine, Hybride, Diesel
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v, 2) & ")"), _
a)) ' transposed columns array = selected rows
' [3] reduce to Dutch and English columns
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & (UBound(a) + 1) & ")"), _
Array(DUTCH, ENGLISH))) ' selected columns array (above array retransposed)
' [4] return concatenated strings
getSplitters = Join(Application.Transpose(Application.Transpose(Application.Index(v, 1, 0))), ", ") & " -> " & _
Join(Application.Transpose(Application.Transpose(Application.Index(v, 2, 0))), ", ")
End Function
Two helper functions
Function getRowAr(ByVal sList As String) As Variant
' Purpose: split comma separated list into 1-dim number array in FREE ORDER
' Example: "Benzine, Hybride, Diesel" -> Array(1, 3, 2)
Dim ar, i&
' change words in comma separated list to numbers
ar = Split(Replace(sList, " ", ""), ",")
For i = LBound(ar) To UBound(ar)
ar(i) = val(getNumber(ar(i))) ' change to numbers
Next i
getRowAr = ar ' return
End Function
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
getNumber = Application.Match(s, arFuel)
End Function
Addendum (Edit due to comment)
The above code works as intended if you are sure that the concatenated search words (or starting parts) actually match else an Error 13 is raised. You can solve this issue in two steps:
Insert an empty first row into your named range Motor (or fill it e.g. with ?, #N/A etc.)
Change the 2nd helper function as follows:
Edited function getNumber()
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
On Error Resume Next ' provide for not found case
getNumber = Application.Match(s, arFuel, 0) ' find only exact matches
If Err.Number <> 0 Then getNumber = 0 ' could be omitted in case of a zero return
End Function
With 2 arrays this is a possible solution:
Sub TestMe()
Dim inputString As String
Dim arrString As Variant
Dim arrResult As Variant
inputString = "Benzine, Diesel, Hybride"
arrString = Split(inputString, ",")
Dim total As Long: total = UBound(arrString)
ReDim arrResult(total)
Dim i As Long
For i = LBound(arrString) To UBound(arrString)
arrResult(total - i) = Trim(arrString(i))
Next i
Debug.Print Join(arrResult, " ,")
End Sub
However, there is a classic solution of this problem, reversing everything twice:
Sub TestMe()
Dim inputString As String
inputString = "Benzine, Diesel, Hybride"
inputString = StrReverse(inputString)
Dim arr As Variant: arr = Split(inputString, ",")
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i) = Trim(StrReverse(arr(i)))
Next i
Debug.Print Join(arr, ", ")
End Sub
I've attached an Example Database with unfinished query that I am looking for help with, image shows what https://dl.dropboxusercontent.com/u/9829095/Result.jpg
Example Database: https://dl.dropboxusercontent.com/u/9829095/Song-V2.accdb
Working solution from Duane Hookom.
Example according to your structure:
SELECT distinct ID
,Concatenate("SELECT distinct Genre FROM qrySong4Export WHERE ID =" & [ID]) as Genre
,Concatenate("SELECT distinct Artist FROM qrySong4Export WHERE ID =" & [ID]) as Artist
from qrySong4Export
Output:
ID Genre Artist
1 Genre 2, Genre 8 6, 12
2 Genre 9 1, 17
3 Genre 10, Genre 13 5
4 Genre 12 4, 5
Code (add it Create -> Module -> [Paste]):
Function Concatenate(pstrSQL As String, _
Optional pstrDelim As String = ", ") _
As String
'Created by Duane Hookom, 2003
'this code may be included in any application/mdb providing
' this statement is left intact
'example
'tblFamily with FamID as numeric primary key
'tblFamMem with FamID, FirstName, DOB,...
'return a comma separated list of FirstNames
'for a FamID
' John, Mary, Susan
'in a Query
'SELECT FamID,
'Concatenate("SELECT FirstName FROM tblFamMem
' WHERE FamID =" & [FamID]) as FirstNames
'FROM tblFamily
'
'======For DAO uncomment next 4 lines=======
'====== comment out ADO below =======
'Dim db As DAO.Database
'Dim rs As DAO.Recordset
'Set db = CurrentDb
'Set rs = db.OpenRecordset(pstrSQL)
'======For ADO uncomment next two lines=====
'====== comment out DAO above ======
Dim rs As New ADODB.Recordset
rs.Open pstrSQL, CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
Dim strConcat As String 'build return string
With rs
If Not .EOF Then
.MoveFirst
Do While Not .EOF
strConcat = strConcat & _
.Fields(0) & pstrDelim
.MoveNext
Loop
End If
.Close
End With
Set rs = Nothing
'====== uncomment next line for DAO ========
'Set db = Nothing
If Len(strConcat) > 0 Then
strConcat = Left(strConcat, _
Len(strConcat) - Len(pstrDelim))
End If
Concatenate = strConcat
End Function
I'm working on a program that can take data from one field in a table and put that whole column into an array or even just read from the table itself. The code seems to use a form or something else I would like to use an array.
This will work:
Dim rstData As DAO.Recordset
Dim v As Variant
Set rstData = CurrentDb.OpenRecordset("select FirstName from FaxBook3")
v = rstData.GetRows(rstData.RecordCount)
"v" will now be a array of all first names. The array will/can be multi-dimensional if your query has multiple columns.
Here's a simple example of how you could take the contents of a column in a table and dynamically add it to the array:
Option Compare Database
Option Explicit
Public Sub loadIntoArray()
Dim rstTableName As DAO.Recordset 'Your table
Dim myArray() As String 'Your dynamic array
Dim intArraySize As Integer 'The size of your array
Dim iCounter As Integer 'Index of the array
'Open your table
Set rstTableName = CurrentDb.OpenRecordset("Table1")
If Not rstTableName.EOF Then
rstTableName.MoveFirst 'Ensure we begin on the first row
'The size of the array should be equal to the number of rows in the table
intArraySize = rstTableName.RecordCount - 1
iCounter = 0
ReDim myArray(intArraySize) 'Need to size the array
Do Until rstTableName.EOF
myArray(iCounter) = rstTableName.Fields("Field1")
Debug.Print "Item: "; iCounter & " " & myArray(iCounter)
iCounter = iCounter + 1
rstTableName.MoveNext
Loop
End If
If IsObject(rstTableName) Then Set rstTableName = Nothing
End Sub
Albert's solution above will work, but you would need to move the recordset to the end and then back again to fill the array fully, otherwise you will only get the first row. Use MoveLast and MoveFirst for this.
Dim rstData As DAO.Recordset
Dim v As Variant
Set rstData = CurrentDb.OpenRecordset("select FirstName from FaxBook3")
rstData.MoveLast
rstData.MoveFirst
v = rstData.GetRows(rstData.RecordCount)
Another way to do that is using the following statements:
Spanish (español): Otra forma de hacerlo es de la siguiente manera:
CLIENTSLIST table: One column
Me.ListFileContent.RowSourceType = "Table/Query"
Me.ListFileContent.RowSource = "CLIENTSLIST"
Note: The ListBox show up all data.