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

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

Related

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

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)

How can I apply multiple conditions to decide what values are written from an array to a target destination?

In an effort to streamline my efforts for a data transfer macro, I have moved to arrays. I have limited experience with them, let alone vba. But I was able to build it, and have it write. The last hurdle I have is that I am unable to specify which values to write, as I only need them transferred if they are over or under a certain amount; i.e. array(dem2, 6) = >300 write, array(dem2, 6) = <300 don't write.
Long story short, I want to be able to write data for rows where that value is either >300 or <-300.
I spent several hours reading posts, trying various loops and conditions including do, do while, goto, elseif but none seem to work and cause errors to pop up.
Public wbFr As Workbook
Public wbTo As Workbook
Public wsFr As Worksheet
Public wsTo As Worksheet
Option Explicit
Public Sub MoveToLogBookArray()
'==================================
' Macro to put data in array '
' Then write to separate workbook '
'==================================
Dim FromArr() As Variant
Dim Dem1 As Long, Dem2 As Long 'Multi-dimensional
Dim lastRow As Long
Dim LR As Long
Dim i As Long
Dim j As Long
Dim test As Boolean
'==================
'Workbook with data
Set wbFr = Workbooks("Book1useV2.xlsm")
'====================
'Destination workbook
Set wbTo = Workbooks("Book2V2.xlsm")
'============
'Source sheet
Set wsFr = wbFr.Worksheets("test")
'=================
'Destination sheet
Set wsTo = wbTo.Worksheets("Sheet7")
With wsFr 'Attempt at setting bounds of array
Dem1 = Range("A2:A10").Cells.Count - 1 '# of rows
Dem2 = Range("A2:A10").Cells.Count - 3 '# of columns
ReDim FromArr(0 To Dem1, 0 To Dem2)
For Dem1 = LBound(FromArr, 1) To UBound(FromArr, 1)
For Dem2 = LBound(FromArr, 2) To UBound(FromArr, 2)
FromArr(Dem1, Dem2) = wsFr.Range("A2").Offset(Dem1, Dem2)
Next Dem2
Next Dem1
End With
'Successfully builds array
'=========================
'Find last row of destination sheet to go to next empty row
With wsTo
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
Else
lastRow = 1
End If
End With
'================================================================
With wsTo
j = lastRow + 1
For i = LBound(FromArr) To UBound(FromArr)
test = True
If FromArr(Dem2, 6) <= 300 Then test = False 'Inputting .value gives error
'do nothing '"Object required"
If FromArr(Dem2, 6) >= 300 Then test = True
If test = False Then
wsTo.Cells(j, 1) = FromArr(i, 0)
wsTo.Cells(j, 2) = FromArr(i, 1)
wsTo.Cells(j, 3) = FromArr(i, 2)
wsTo.Cells(j, 4) = FromArr(i, 3)
wsTo.Cells(j, 10) = FromArr(i, 4)
wsTo.Cells(j, 13) = FromArr(i, 5)
wsTo.Cells(j, 17) = FromArr(i, 6)
j = j + 1
End If '=======================================================
Next i 'I'm unable to write only values over 300 or under -300]
End With '=======================================================
Exit Sub
End Sub
As mentioned above, I want to be able to specify rows of values input into an array in one workbook, then write them to a separate workbook based on conditions of column 6.
With wsTo 'set break here
j = lastRow + 1
For i = LBound(FromArr) To UBound(FromArr)
test = (FromArr(Dem2, 6) <= -300) And (FromArr(Dem2, 6) >= 300) '= True/False
'tried both false/true and commented out^^^^^
'and flipping <, >
If test = True Then
'do nothing
End If
'When it writes, it writes all values or no values at all
'````````````````````````````````````````````````````````
If test = False Then 'values for 4&5 include decimals
wsTo.Cells(j, 1) = FromArr(i, 0) 'type= variant/double
wsTo.Cells(j, 2) = FromArr(i, 1) 'type= variant/string
wsTo.Cells(j, 3) = FromArr(i, 2) 'type= variant/string
wsTo.Cells(j, 4) = FromArr(i, 3) 'type= variant/string
wsTo.Cells(j, 10) = FromArr(i, 4) 'type= variant/double
wsTo.Cells(j, 13) = FromArr(i, 5) 'type= variant/double
wsTo.Cells(j, 17) = FromArr(i, 6) 'type= variant/double
j = j + 1 'On 4th iteration, value is 285 but is written anyway
End If
'=======================================================
Next i 'I'm unable to write only values over 300 or under -300]
End With '=======================================================
Exit Sub
'Values in test Column
'517.34
'733.68
'312.26
'285.00 writes regardless
'297.00 ""
'312.00
'333.00
'250.00 ""
'500.00
End Sub
And here is my finished working project thanks to Robert and Patrick.
Public wbFr As Workbook
Public wbTo As Workbook
Public wsFr As Worksheet
Public wsTo As Worksheet
Option Explicit
Public Sub MoveToLogBookArray()
'==================================
' Macro to put data in array '
' Then write to separate workbook '
'==================================
Dim FromArr() As Variant
Dim lastRow As Long
Dim i As Long
Dim j As Long
Dim test As Boolean
'==================
'Workbook with data
Set wbFr = Workbooks("Book1useV2.xlsm")
'====================
'Destination workbook
Set wbTo = Workbooks("Book2V2.xlsm")
'============
'Source sheet
Set wsFr = wbFr.Worksheets("test")
'=================
'Destination sheet
Set wsTo = wbTo.Worksheets("Sheet7")
'========================================================================
With wsFr 'Attempt at setting bounds of array
FromArr = Range("adjRange")
End With
With wsTo
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
Else
lastRow = 1
End If
End With
'===================================================================
'Be sure to verify parameters
'Check for errors
On Error GoTo ErrHandler
With wsTo
j = lastRow + 1
For i = LBound(FromArr) To UBound(FromArr)
test = False
If FromArr(i, 6) >= 300 And FromArr(i, 6) <= -300 Then test = False
If FromArr(i, 6) < 299.99 And FromArr(i, 6) > -299.99 Then test = True
If test = False Then
wsTo.Cells(j, 1) = FromArr(i, 1)
wsTo.Cells(j, 2) = FromArr(i, 2)
wsTo.Cells(j, 3) = FromArr(i, 3)
wsTo.Cells(j, 4) = FromArr(i, 4)
wsTo.Cells(j, 10) = FromArr(i, 5)
wsTo.Cells(j, 13) = FromArr(i, 6)
wsTo.Cells(j, 17) = FromArr(i, 7)
j = j + 1
End If
Next i
End With
On Error GoTo 0
'===================================================================
Exit Sub
ErrHandler:
MsgBox "An error has occurred! Please check values are in correct column. " & Err.Description
Exit Sub
End Sub
This should work. You had a typo in the index to the FromArr(). I could not run it, so let me know if it does not work.
With wsTo
j = lastRow + 1
For i = LBound(FromArr, 1) To UBound(FromArr2, 1)
If FromArr(i, 6) <= 300 Then test = False
If FromArr(1, 6) > 300 Then test = True
If test = False Then
wsTo.Cells(j, 1) = FromArr(i, 0)
wsTo.Cells(j, 2) = FromArr(i, 1)
wsTo.Cells(j, 3) = FromArr(i, 2)
wsTo.Cells(j, 4) = FromArr(i, 3)
wsTo.Cells(j, 10) = FromArr(i, 4)
wsTo.Cells(j, 13) = FromArr(i, 5)
wsTo.Cells(j, 17) = FromArr(i, 6)
j = j + 1
End If
Next i
End With

Match VBA Array values and overwrite duplicates

Welcome!
I have problem with preparing function or part of the code which provides operation on data in structure below (data in this format is already stored in Array):
ID Flag Company
33 AB 67345
33 ABC 53245
33 C 67345
33 AB 25897
33 A 89217
33 BC 81237
33 B 89217
33 C 89217
The purpose of the exercise is to obtain new array with combined records based on the key ID + Company. So basically output should be:
33 ABC 67345
33 ABC 53245
33 AB 25897
33 ABC 89217
33 BC 81237
I have tried several solution but still not getting final result. I used loops or comparing methods.
Can anyone provide vital solution? Performance is not a key at this point, the most important is solution that will solve this problem.
I have tried solution with moving values from Array to another but still I get duplicated rows for example:
33 ABC 89217
33 AB 89217
33 C 89217
Example of the code:
For i = 1 To UBound(Array1)
If Array1(i, 13) <> "Matched" Then
strTestCase = Array1(i, 1) & Array1(i, 9)
strLegalEntityType = EntityFlag(Array1(i, 5))
For j = 1 To UBound(Array1)
If Array1(j, 1) & Array1(j, 9) = strTestCase Then
Array1(i, 13) = "Matched"
End If
If EntityFlag(Array1(i, 5)) = EntityFlag(Array1(j, 5)) Then
arrTemporary1(i, 5) = EntityFlag(Array1(j, 5)) & strLegalEntityType
arrTemporary1(i, 5) = funcRemoveDuplicates(arrTemporary1(i, 5))
arrTemporary1(i, 1) = Array1(i, 1)
arrTemporary1(i, 2) = Array1(i, 2)
arrTemporary1(i, 3) = Array1(i, 3)
arrTemporary1(i, 4) = Array1(i, 4)
arrTemporary1(i, 6) = Array1(i, 6)
arrTemporary1(i, 7) = Array1(i, 7)
arrTemporary1(i, 8) = Array1(i, 8)
arrTemporary1(i, 9) = Array1(i, 9)
arrTemporary1(i, 10) = Array1(i, 10)
arrTemporary1(i, 11) = Array1(i, 11)
arrTemporary1(i, 12) = Array1(i, 12)
a = a + 1
End If
Next j
End If
Next i
This can be done in Power Query (aka Get&Transform in Excel 2016+)
Group the Rows by ID and Company with Operation = "All Rows"
Add a custom column to change the resultant table into a list:
Formula for custom column: Table.Column([Grouped],"Flag")
Select the double headed arrow at the top of the "Custom" column and"Extract" values from the list with "none" for the delimiter
The above can all be done from the user interface, (with manual entry of the formula for the custom column), but here is the resultant M-Code:
let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"ID", Int64.Type}, {"Flag", type text}, {"Company", Int64.Type}}),
#"Grouped Rows" = Table.Group(#"Changed Type", {"ID", "Company"}, {{"Grouped", each _, type table [ID=number, Flag=text, Company=number]}}),
#"Added Custom" = Table.AddColumn(#"Grouped Rows", "Custom", each Table.Column([Grouped],"Flag")),
#"Extracted Values" = Table.TransformColumns(#"Added Custom", {"Custom", each Text.Combine(List.Transform(_, Text.From)), type text})
in
#"Extracted Values"
You can achieve this by using a dictionary. To use dictionaries you will need to add a reference to Microsoft Scripting Runtime
Sub demo()
Dim dict As New Scripting.Dictionary
Dim arr As Variant
Dim i As Long
Dim tmpID As String
Dim k
Dim tmpFlag As String
' Set range to variant
' Update with your sheet reference and range location
With ActiveSheet
arr = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3))
End With
' Loop through array
For i = LBound(arr, 1) To UBound(arr, 1)
' Create composite ID of ID and Company
tmpID = arr(i, 1) & "," & arr(i, 3)
' If it doesn't exist add to dictionary
If Not dict.Exists(tmpID) Then
dict.Add Key:=tmpID, Item:=arr(i, 2)
' If it does exist append value
Else
tmpFlag = StrConv(dict(tmpID) & arr(i, 2), vbUnicode)
tmpFlag = Join(SortArrayAtoZ(Split(tmpFlag, Chr$(0), Len(tmpFlag))), "")
dict(tmpID) = tmpFlag
End If
Next i
' Read back results
ReDim arr(1 To dict.Count, 1 To 3)
Dim arrCount As Long
' Debug.Print results can be viewed in the Immediate Window
Debug.Print "ID", "Flag", "Company"
For Each k In dict.Keys
arrCount = arrCount + 1
arr(arrCount, 1) = Split(k, ",")(0)
arr(arrCount, 2) = dict(k)
arr(arrCount, 3) = Split(k, ",")(1)
Debug.Print Split(k, ",")(0), dict(k), Split(k, ",")(1)
Next k
' Update with first cell of desired location of results
With ActiveSheet
.Cells(2, 5).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Function SortArrayAtoZ(myArray As Variant)
Dim i As Long
Dim j As Long
Dim Temp
'Sort the Array A-Z
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray)
If UCase(myArray(i)) > UCase(myArray(j)) Then
Temp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = Temp
End If
Next j
Next i
SortArrayAtoZ = myArray
End Function

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

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

Resources