Copy the values of a collection to a 2D array in VBA - arrays

I seem to be banging my ahead against the proverbial brick wall. I have a loop which runs and populates a collection. There are approximately 20000 rows and 11 columns. I need to be able to get the contents of the collection into a variant array so that I can do a bulk copy to a worksheet. The reason I was using a collection is for the inherent de-duplication of entries.
Please could someone offer a suggestion as to how to achieve this. I assume I am missing something straightforward but if I dont use a collection I need to dedupliate 200k+ rows.
Thanks in advance for all your help
EDIT
Here is the actual code. As I mentioned above, the problem is not getting the data into the collection (MyCollection), its getting it out again!
EDIT
The flow of data starts in a worksheet which is then copied into an array called ArrayOrg. The array is looped through and when certain conditions are satisfied, a record is added to the ArrayOrg1 array. Please see the code below.
For intI = 1 To UBound(ArrayOrg())
If ArrayOrg(intI, 7) = "cMat" And ArrayOrg(intI, 5) = "Plant" Then
ArrayOrg1_cMat(Org1Count_cMat, 0) = ArrayOrg(intI, 1) 'User ID
ArrayOrg1_cMat(Org1Count_cMat, 1) = ArrayOrg(intI, 2) 'BR ID
ArrayOrg1_cMat(Org1Count_cMat, 2) = ArrayOrg(intI, 3) 'Scenario
ArrayOrg1_cMat(Org1Count_cMat, 3) = ArrayOrg(intI, 4) 'Role
ArrayOrg1_cMat(Org1Count_cMat, 4) = ArrayOrg(intI, 5) 'Controlling Field
ArrayOrg1_cMat(Org1Count_cMat, 5) = ArrayOrg(intI, 6) 'Controlling Field Value
ArrayOrg1_cMat(Org1Count_cMat, 6) = ArrayOrg(intI, 7) 'Webapp
Org1Count_cMat = Org1Count_cMat + 1
Next intI
Dim MyCollection As Collection
Dim ArrayTemp() As Variant
Set MyCollection = New Collection
For intI = 0 To UBound(ArrayOrg1_cMat())
For intJ = 0 To UBound(ArrayOrg2_cMat())
If ArrayOrg2_cMat(intJ, 0) = ArrayOrg1_cMat(intI, 0) Then
If ArrayOrg2_cMat(intJ, 1) = ArrayOrg1_cMat(intI, 1 Then If ArrayOrg2_cMat(intJ, 2) = ArrayOrg1_cMat(intI, 2) Then If ArrayOrg2_cMat(intJ, 3) = ArrayOrg1_cMat(intI, 3) Then
ArrayTemp(0, 0) = "" 'Name
ArrayTemp(0, 1) = ArrayOrg1_cMat(intI, 0) 'AD ID
ArrayTemp(0, 2) = "" 'Email
ArrayTemp(0, 3) = "" 'Requester
ArrayTemp(0, 4) = ArrayOrg1_cMat(intI, 6) 'Webapp
ArrayTemp(0, 5) = ArrayOrg1_cMat(intI, 2) 'Scenario
ArrayTemp(0, 6) = ArrayOrg1_cMat(intI, 3) 'Role
ArrayTemp(0, 7) = "PL" 'Business Unit
ArrayTemp(0, 8) = "NONE"
ArrayTemp(0, 9) = "NONE"
ArrayTemp(0, 10) = "NONE"
ArrayTemp(0, 11) = ArrayTemp(0, 0) & ArrayTemp(0, 1) & ArrayTemp (0, 2) & ArrayTemp(0, 3) & ArrayTemp(0, 4) _
& ArrayTemp(0, 5) & ArrayTemp(0, 6) & ArrayTemp (0, 7) & ArrayTemp(0, 8) & ArrayTemp(0, 9) _
& ArrayTemp(0, 10) '### This is the key for the collection
On Error Resume Next
MyCollection.Add ArrayTemp, ArrayTemp(0, 11)
On Error GoTo 0
End If
End If
End If
End If
Next intJ
Next intI
'#### THIS IS WHERE THE PROBLEM IS
For intI = 0 To MyCollection.Count
ArrayOutput(intI, 0) = MyCollection.Item(intI)
Next intI
Thanks
Kevin

Sub Tester()
Dim k As String
Dim i As Long, j As Long, r As Long, x As Long
Dim arr() As Variant
Dim dict
ReDim arr(1 To UBound(ArrayOrg1_cMat, 1) + 1, 1 To 11)
r = 0
Set dict = CreateObject("scripting.dictionary")
For i = 0 To UBound(ArrayOrg1_cMat())
For j = 0 To UBound(ArrayOrg2_cMat())
If ArrayOrg2_cMat(j, 0) = ArrayOrg1_cMat(i, 0) Then
If ArrayOrg2_cMat(j, 1) = ArrayOrg1_cMat(i, 1) Then
If ArrayOrg2_cMat(j, 2) = ArrayOrg1_cMat(i, 2) Then
If ArrayOrg2_cMat(j, 3) = ArrayOrg1_cMat(i, 3) Then
' I'm skipping the constant values in your original key...
k = Join(Array(ArrayOrg1_cMat(i, 0), _
ArrayOrg1_cMat(i, 6), _
ArrayOrg1_cMat(i, 2), _
ArrayOrg1_cMat(i, 3)), "~")
If Not dict.exists(k) Then
r = r + 1
dict.Add k, True
arr(r, 1) = "" 'Name
arr(r, 2) = ArrayOrg1_cMat(i, 0) 'AD ID
arr(r, 3) = "" 'Email
arr(r, 4) = "" 'Requester
arr(r, 5) = ArrayOrg1_cMat(i, 6) 'Webapp
arr(r, 6) = ArrayOrg1_cMat(i, 2) 'Scenario
arr(r, 7) = ArrayOrg1_cMat(i, 3) 'Role
arr(r, 8) = "PL" 'Business Unit
arr(r, 9) = "NONE"
arr(r, 10) = "NONE"
arr(r, 11) = "NONE"
End If
End If
End If
End If
End If
Next j
Next i
ActiveSheet.Range("a2").Resize(r, 11).Value = arr
End Sub

Related

Excel vba: type mismatch error on Array date format

Can someone help me on this error please..
getting type mismatch error on Array date format in the line mentioned below.
mykey = arr(i, 7) & format(arr(i, 11), "|dd-mmm-yy") 'job name & start date
Please help me on this.
Code:
Dim T_Start, T_Stop, Shift_Start, Shift_Stop, Result
Set dict = CreateObject("scripting.dictionary")
Set lo = Sheets("temp_sheet").ListObjects("TBL_Jobs")
arr = lo.DataBodyRange.Value2 'read that table to an array
ReDim Result(1 To UBound(arr), 1 To 1)
'1st ROUND : find last status at the end of the shift
For i = 1 To UBound(arr) 'loop through data
T_Start = arr(i, 11) + arr(i, 12) 'timestamp end of job
T_Stop = arr(i, 14) + arr(i, 15) 'timestamp end of job
mykey = arr(i, 7) & format(arr(i, 11), "\|dd-mmm-yy") 'job name & start date
If arr(i, 11) = arr(i, 14) Then
If T_Stop <= arr(i, 11) + TimeSerial(15, 0, 0) Then 'job must end before next day 3PM
If Not dict.exists(mykey) Then
dict(mykey) = Array(T_Stop, arr(i, 10))
Else
If dict(mykey)(0) < T_Stop Then dict(mykey) = Array(T_Stop, arr(i, 10)) '---> for that job and that startdate, the last endmoment & status
End If
Else
Result(i, 1) = "Notwithinshift"
End If
Else
If T_Stop <= arr(i, 11) + 1 + TimeSerial(15, 0, 0) Then 'job must end before next day 3PM
If Not dict.exists(mykey) Then
dict(mykey) = Array(T_Stop, arr(i, 10))
Else
If dict(mykey)(0) < T_Stop Then dict(mykey) = Array(T_Stop, arr(i, 10)) '---> for that job and that startdate, the last endmoment & status
End If
Else
Result(i, 1) = "Notwithinshift"
End If
End If
Next
'2nd ROUND : add status corresponding with status "end of shift"
For i = 1 To UBound(arr) 'loop through data
If Len(Result(i, 1)) = 0 Then 'no blocking conditions
mykey = arr(i, 1) & format(arr(i, 11), "\|dd-mmm-yy") 'key within dictionary
Result(i, 1) = dict(mykey)(1) 'last known status
End If
Next
lo.ListColumns("Final Status").DataBodyRange.Value = Result 'write array to listobject
End Sub
Getting the issue in another line.. could you please help..
I recreated the table and ran your macro. It compiles just fine and writes result to column 'Final Status'.
Looks like the error on line
mykey = arr(i, 7) & format(arr(i, 11), "|dd-mmm-yy")
could be due to formatting issue. In table column 7 (arr(i, 7)) I set the format to "Time". Your picture only shows 9 columns, but set your format in column 11 to "Short Date", it worked for me.

Excel VBA Subscript out of range error in array when assigning values to array

I am working on a similar data set as below:
My data details
I am looping in the data as per Column Job and trying to find out successor mapped for the job. Post which I am assigning the Successor and Retirement year to my 2 dimensional array. Post this I am trying to assign the array to a listbox. Here is my code:
Dim hjselected As Variant
hjselected = frmform1.ComboBox1.Value
iRow = [Counta(Database_HJ!A:A)] - 1
Dim arrayrow As Variant
arrayrow = 0 'variable for array row size
For countRow = 2 To iRow 'to find array row size I need based on number of incumbent
If (hjselected = Sheet2.Cells(countRow, 1)) Then
arrayrow = arrayrow + 1
End If
Next countRow
Dim varA() As Variant
ReDim varA(arrayrow, 6)
For countRow = 2 To iRow
If (hjselected = Sheet2.Cells(countRow, 1)) Then
varA(countRow, 1) = Sheet2.Cells(countRow, 9)
varA(countRow, 2) = Sheet2.Cells(countRow, 10)
varA(countRow, 3) = Sheet2.Cells(countRow, 11)
varA(countRow, 4) = Sheet2.Cells(countRow, 12)
varA(countRow, 5) = Sheet2.Cells(countRow, 13)
varA(countRow, 6) = Sheet2.Cells(countRow, 14)
End If
Next countRow
frmform1.ListBox1.List = varA
I am constantly getting a Subscript out of range error when the second for loop is running for the 2nd time. Any help would be appreciated, thank you very much.
I was using the countrow to add values to the array but countrow will have much larger value. I used one more counter to go around it.
Dim arrayI As Long
arrayI = 1
For countRow = 2 To iRow
If (hjselected = Sheet2.Cells(countRow, 1)) Then
varA(arrayI, 1) = Sheet2.Cells(countRow, 9)
varA(arrayI, 2) = Sheet2.Cells(countRow, 10)
varA(arrayI, 3) = Sheet2.Cells(countRow, 11)
varA(arrayI, 4) = Sheet2.Cells(countRow, 12)
varA(arrayI, 5) = Sheet2.Cells(countRow, 13)
varA(arrayI, 6) = Sheet2.Cells(countRow, 14)
arrayI = arrayI + 1
End If
Next countRow

Using Excel VBA to send data to access database from an array

I am trying to change my code from storing data to excel spreadsheets to send to access database.
This is the code
If qty.Value <> "" Then
PatientDetails(1, 1) = LastRow - 1
zh.Cells(LastRow, 1).Resize(, 22) = PatientDetails
zh.Cells(LastRow, 23) = servees.Value
zh.Cells(LastRow, 25) = qty.Value
zh.Cells(LastRow, 27) = cost.Value
zh.Cells(LastRow, 29) = ThisWorkbook.Sheets("Support").Range("AM1").Value
zh.Cells(LastRow, 30) = [Text(Now(), "DD-MM-YY HH:MM:SS")]
LastRow = LastRow + 1
End If
'Next
im only posting the code that relates to the help i need,
zh is the sheet,LastRow is supposed to find the next empty row,
this section of code runs in a loop,
NOW "PatientDetails" is an array with data used to populate column1 to column22.
In changing this code to be able to send to access,
since i used
zh.Cells(LastRow, 1).Resize(, 22) = PatientDetails
to populate the first 22 columns of my spreadsheet.
If i want to send "PatientDetails" to access,
how do i populate access fields/columns with "PatientDetails"
This is the array
Private Function PatientDetails() As Variant
Dim ar(1 To 1, 1 To 22)
With PrivGNI
ar(1, 1) = 0
ar(1, 2) = "GNI HMO (PRIVATE)"
ar(1, 3) = .Txt_EnrolleeNoGNI.Value
ar(1, 4) = "Nil"
ar(1, 5) = Private_PreEntryForm1.cmb_ReferFromPef2.Value
ar(1, 6) = .Txt_EnrolleeNameGNI.Value
ar(1, 7) = .Txt_AuthorizationCode.Value
ar(1, 8) = Private_PreEntryForm1.Txt_AuthorisingOfficerPEF.Value
If Private_PreEntryForm1.Opt_OutpatientPef = True Then
ar(1, 9) = "OUTPATIENT"
Else
ar(1, 9) = "Nil"
End If
If Private_PreEntryForm1.Opt_InpatientPef2 = True Then
ar(1, 9) = "INPATIENT"
Else
ar(1, 9) = "Nil"
End If
ar(1, 10) = Private_PreEntryForm1.Cmb_PatientPlan.Value
ar(1, 11) = "PRIVATE HMO"
ar(1, 12) = .Txt_HmoCodeGNI.Value
ar(1, 13) = .txt_DateOfserv2.Value
ar(1, 14) = .Txt_DateOfAdmGNI.Value
ar(1, 15) = .Txt_DateOfDisGNI.Value
ar(1, 16) = Private_PreEntryForm1.cmd_Genderpef2.Value
ar(1, 17) = .Txt_AgeGNI.Value
ar(1, 18) = .Txt_SexGNI
ar(1, 19) = .txt_drsNameGNI
ar(1, 20) = "Nil"
ar(1, 21) = .Txt_DiagnosisGNI.Value
ar(1, 22) = .txt_PhoneGNI.Value
End With
PatientDetails = ar
End Function
if i may add,
does it make any sense to say
"Recordset.Fields(1,2,3,4,5,6 to 22).Value = PatientDetails"
Its only this line of code i need help on.
The ADO property or method that can refer to multiple columns/fields alongside the "fields" object to Send the array to access

VBA Dynamice Array subscript out of range

I am pretty new with VBA and trying to write a code to import data from many files in the same folder into a new workbook. I used a dynamic array to update the data but still got the subscript out of range error. I am getting error at Arr(1, 14) = RngInt(2, 1) - Sheets("A").Range("N" & R) when debugged .Can you help me in rectifying the error so that the code may be able to function correctly? Thanks a lot. Here is my code:
Sub CopyDataBetweenWorkbooks()
Dim Arr(), R As Long, FinalRow As Long, x As Integer
Dim wbSource As Workbook
Dim shTarget As Worksheet
Dim shSource As Worksheet
Dim strFilePath As String
Dim strPath As String
' Initialize some variables and ' get the folder path that has the files
Set shTarget = ThisWorkbook.Sheets("A")
strPath = ThisWorkbook.Sheets("A").Range("Path") & "\"
' Make sure a folder was picked.
If Not strPath = vbNullString Then
' Get all the files from the folder
strfile = Dir(strPath)
While strfile <> ""
R = ThisWorkbook.Sheets("A").Range("A" & Rows.Count).End(xlUp).Row + 1
' Open the file and get the source sheet
Set wbSource = Workbooks.Open(strPath & strfile)
'Copy the data
RngInt = wbSource.Sheets("Int").Range("D5:D26")
RngExt = wbSource.Sheets("Ext").Range("D5:D26")
ReDim Arr(1 To 2, 1 To 28)
Arr(1, 1) = wbSource.Name
If RngInt(1, 1) = 0 Then
Arr(1, 2) = RngInt(2, 1)
Else
Arr(1, 2) = RngInt(1, 1)
End If
Arr(1, 3) = RngInt(4, 1)
Arr(1, 4) = RngInt(5, 1)
Arr(1, 5) = RngInt(6, 1)
Arr(1, 6) = RngInt(7, 1)
Arr(1, 7) = RngInt(17, 1) * (-1)
If RngExt(1, 1) = 0 Then
Arr(1, 8) = RngExt(2, 1)
Else
Arr(1, 8) = RngExt(1, 1)
End If
Arr(1, 9) = RngExt(4, 1)
Arr(1, 10) = RngExt(5, 1)
Arr(1, 11) = RngExt(6, 1)
Arr(1, 12) = RngExt(7, 1)
Arr(1, 13) = RngExt(17, 1) * (-1)
Arr(1, 14) = RngInt(2, 1) - Sheets("A").Range("N" & R)
Arr(1, 15) = RngInt(3, 1) - Sheets("A").Range("O" & R)
'And so on, until arr (1,27)
ThisWorkbook.Sheets("A").Range("A" & R).Resize(1, 28) = Arr
'Close the workbook and move to the next file.
wbSource.Close
strfile = Dir$()
Wend
End If
End Sub
Try,
Arr(1, 14) = RngInt(2, 1) - ThisWorkbook.Sheets("A").Range("N" & R)
Arr(1, 15) = RngInt(3, 1) - ThisWorkbook.Sheets("A").Range("O" & R)

Why did my VBA array contents disappear when I wanted to reuse them?

I am a newbie to VBA and have been developing a macro that involves arrays.
In the array part, I need to copy some ranges from two excel workbooks into two separate arrays(timearray and guzikarray). Then I will try to match the two arrays and copied the results into a third array(masterarray). Lastly I will write the third array's contents back into the worksheet.
But I found that my first two arrays' contents are automatically erased when I started to do the matching. So nothing was written back to my worksheet. Anyone can tell me why?
'copy ranges to two arrays: timearray and guzikarray
masterrows = mastersheet.UsedRange.Rows.count
guzikrows = guziksheet.UsedRange.Rows.count
ReDim timearray(1 To masterrows, 1 To 2)
For i = 1 To i = masterrows
timearray(i, 1) = Cells(i, 6).Value
timearray(i, 2) = Cells(i, 10).Value
Next
ReDim guzikarray(1 To guzikrows, 1 To 6)
For i = 1 To i = guzikrows
guzikarray(i, 1) = guziksheet.Cells(i, 11).Value
guzikarray(i, 2) = guziksheet.Cells(i, 17).Value
guzikarray(i, 3) = guziksheet.Cells(i, 14).Value
guzikarray(i, 4) = guziksheet.Cells(i, 16).Value
guzikarray(i, 5) = guziksheet.Cells(i, 18).Value
guzikarray(i, 6) = guziksheet.Cells(i, 26).Value
Next
'match timearray and guzikarray, and then copied the results to masterarray
ReDim Preserve masterarray(1 To masterrows, 1 To 4)
For i = 2 To i = masterrows
min = 100000
For j = 2 To j = guzikrows
If timearray(i, 1) = guzikarray(j, 1) Then
If timearray(i, 2) = guzikarray(j, 2) Then
If guzikarray(j, 6) <> 0 Then
masterarray(i, 1) = guzikarray(j, 4)
masterarray(i, 3) = guzikarray(j, 3)
If guzikarray(j, 5) < min Then
min = guzikarray(j, 5)
masterarray(i, 2) = min
End If
If timearray(i, 1) <> timearray(i + 1, 1) Then
If timearray(i, 1) <> timearray(i - 1, 1) Then
If guzikarray(j, 2) <> guzikarray(j - 1, 2) Then masterarray(i, 4) = guzikarray(j - 1, 5)
End If
End If
End If
End If
End If
Next
Next
'write the results back to master array
Range(Cells(2, 17), Cells(masterrows, 20)).Value = masterarray
Your loops aren't working as the syntax is incorrect
For i = 1 To i = masterrows
exits immediately without populating the array. You should be using
For i = 1 To masterrows
For i = 1 To guzikrows
etc

Resources