Help with comparing 2 Arrays (searching elements)

[BMRC]

Hi all,

I have thought and array'd myself into a corner and would love a guiding light on this one...

I have 2 arrays and want to populate a third with the values that match between Array1 and Array2.(up to this point everythign works)

And (this is where I am stumbling) I want to populate Array4 with all matching values and all unique values, but no duplicates from Array1 and Array2.

I am working in a test file and not yet working with my actual data. (I want to make it work small scale first) I cannot find a way search through Array2, find an element that does not match any in Array1 and load to Array4. I've tried Join, Match, strange loops

(values need to be a mixture of string and integer)

Thanks for any advice....BMRC


Worksheets "TEST" has the following:

Sub Test()
'Build Array 1
    LastRowA1 = Application.WorksheetFunction.CountA(Worksheets("TEST").Range("A:A")) - 1
    LastColumnA1 = 2
    ColNum1 = LastColumnA1
    RowNum1 = LastRowA1
        ReDim Array1(ColNum1, RowNum1)
        For x = 0 To ColNum1 - 1
            For i = 0 To RowNum1
            Array1(x, i) = Worksheets("TEST").Cells(i + 1, x + 1).Value
            Next
        Next
'Build Array 2
    LastRowA2 = Application.WorksheetFunction.CountA(Worksheets("TEST").Range("C:C")) - 1
    LastColumnA2 = 2
    ColNum2 = LastColumnA2
    RowNum2 = LastRowA2
        ReDim array2(ColNum2, RowNum2)
        For x = 0 To ColNum2 - 1
            For i = 0 To RowNum2
            array2(x, i) = Worksheets("TEST").Cells(i + 1, x + 3).Value
            Next
        Next
'Build Array 3
    'Shows only matches between Array1 and Array2
    ColNum = 2
    RowNum = RowNum1 + RowNum2
        ReDim Array3(ColNum, RowNum)
        Array3(0, 0) = "Matching only"
For i = 1 To RowNum1
    For ii = 1 To RowNum2
        If Array1(0, i) = array2(0, ii) Then
            Array3(0, i) = Array1(0, i)
            Array3(1, i) = Array1(1, i)
        End If
    Next ii
Next i
'Build Array4
'TEST (Want to buid array that has All of  Array1 and the unique values from Array2)
    ColNum = 2
    RowNum = RowNum1 + RowNum2
        ReDim Array4(ColNum, RowNum)
        Array4(0, 0) = "Combined Array"
         For x = 0 To ColNum
            For i = 1 To RowNum1
            Array4(x, i) = Array1(x, i)
            Next
        Next
        For x = 0 To RowNum
            If Array4(0, x) = "" Then
                EndArray = x
                x = RowNum
            End If
        Next x
 ''This works, but only if the lists are identical and in order except for the new values.(not a true search)
    For i = 1 To RowNum2
        For x = 0 To RowNum
            If Array4(0, x) = "" Then
                EndArray = x
                x = RowNum
            End If
        Next x
               If array2(0, i) <> Array4(0, i) Then
                    Array4(0, EndArray) = array2(0, i)
                    Array4(1, EndArray) = array2(1, i)
               End If
    Next i
End Sub

 

[chirp]

okay so this function should be able to be modified (fairly easily) to do what you want. right now it returns a two element jagged array, the first element with any values in "range1" and not in "range2", and the second with any values in "range2" and not in "range1".

turned out to use a lot more functions than i thought, but if you want to go through it im sure it is exciting

'this returns an array with the first entry an array of all in r1 not r1, and 2nd all in r2 not r1

'used in a few range functions
Public Enum cornerCell
    leftTop = 0
    rightTop = 1
    leftBottom = 2
    rightBottom = 3
End Enum


'supports multiple areas, but slower
Public Function getDifferencesArr(range1 As Range, range2 As Range, _
                                    Optional skipBlanks As Boolean = True, _
                                    Optional matchCase As Boolean = True, _
                                    Optional tst As Boolean) As Variant

Dim uDic1 As Object, uDic2 As Object, uDic3 As Object
Dim Var As Variant, rngArr As Variant
Dim tmpArr(1 To 2) As Variant
Dim funcTest As Boolean

tst = False
On Error GoTo exitFunc

'if either range is nothing then exit
If range1 Is Nothing Then Exit Function
If range2 Is Nothing Then Exit Function

'creates 3 dics using late binding...increase speed set reference
Set uDic1 = CreateObject("scripting.dictionary")
Set uDic2 = CreateObject("scripting.dictionary")
Set uDic3 = CreateObject("scripting.dictionary")

If Not matchCase Then
    uDic1.compareMode = vbTextCompare
    uDic2.compareMode = vbTextCompare
    uDic3.compareMode = vbTextCompare
End If

'set initial array for first range
If range1.Areas.count > 1 Then
    rngArr = maRangeToVar(range1, funcTest)
    If Not funcTest Then Exit Function
Else
    rngArr = rUsedrange(range1).Value2
End If

With uDic1
    For Each Var In rngArr
        Var = CStr(Var)
        If skipBlanks Then
            If Var = vbNullString Then GoTo skipAdd
        End If
        .Item(Var) = Null
skipAdd:
    Next
End With

'This is likely unnecessarily complex, but is the most intuitive way of doing it, and speedwise
'i believe it is OK
With uDic2
    'reassign rngArr
    If range2.Areas.count > 1 Then
        rngArr = maRangeToVar(range2, funcTest) 'just returns all cells in a variant array
        If Not funcTest Then Exit Function
    Else
        rngArr = rUsedrange(range2).Value2
    End If
    
    For Each Var In rngArr
        Var = CStr(Var)
        If Not uDic1.Exists(Var) Then
            If Not uDic3.Exists(Var) Then
                If skipBlanks Then
                    If Var = vbNullString Then GoTo skipAdd1
                End If
                .Add Var, Null
            End If
        Else
            If Not uDic3.Exists(Var) Then uDic3.Add Var, Null
            uDic1.Remove (Var)
        End If
skipAdd1:
    Next

    tmpArr(1) = uDic1.Keys
    tmpArr(2) = .Keys
End With

getDifferencesArr = tmpArr
tst = True
exitFunc:
End Function

it uses a couple of other functions which use a couple other functions which is a little annoying but here they are:

'this returns a "jagged" array of variant type, in syntax retArr(row)(1,col)
Public Function maRangeToVar(rng As Range, _
                            Optional tst As Boolean) As Variant
                            
Dim tmpArr
Dim tmpArea As Range, rw As Range
Dim cnt As Long

tst = False
On Error GoTo exitFunc

If rng Is Nothing Then Exit Function

ReDim tmpArr(1 To getRowCnt(rng))

For Each tmpArea In rng.Areas
    For Each rw In tmpArea.Rows
        cnt = cnt + 1
        tmpArr(cnt) = rw
    Next
Next

maRangeToVar = tmpArr
tst = True

exitFunc:
End Function

'gets the real used range using the first/last col/row functions
Public Function rUsedrange(withinRange As Range, _
                            Optional LookIn As XlFindLookIn = xlFormulas, _
                            Optional removeAutoFilter As Boolean = False, _
                            Optional tst As Boolean) As Range
Dim lr As Long, fr As Long, lc As Long, fc As Long

tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then Exit Function
'If WorksheetFunction.CountA(withinRange) < 1 Then Exit Function

If removeAutoFilter Then Call offAuto(withinRange.Parent)

lr = LastRow(withinRange, LookIn)
fr = firstRow(withinRange, LookIn)
lc = lastCol(withinRange, LookIn)
fc = firstCol(withinRange, LookIn)


With withinRange.Parent
    Set rUsedrange = .Range(.Cells(fr, fc), .Cells(lr, lc))
End With

tst = True
exitFunc:
End Function

'switches off auto filter
Public Function offAuto(ws As Worksheet)
If ws Is Nothing Then Exit Function
If ws.AutoFilterMode = True Then ws.AutoFilterMode = False
End Function

'THESE USE THE FIND METHOD FOR LAST/FIRST ROW/COL, use if searching full sheet/large range
'gets last/first row/column (searches within values or formulas)
'the find method seems to have an overhead of about .25 seconds/1000 calls
'the increase in time/range size is then about .7 seconds/2560000 searched cells/1000 calls

Public Function LastRow(withinRange As Range, Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long
On Error Resume Next
    With withinRange
            LastRow = .Find("*", getCornerRange(withinRange, leftTop), LookIn, xlPart, xlByRows, xlPrevious).Row
    End With
    tst = Err.Number = 0
End Function

Public Function lastCol(withinRange As Range, Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long
On Error Resume Next
    With withinRange
            lastCol = .Find("*", getCornerRange(withinRange, leftTop), LookIn, xlPart, xlByColumns, xlPrevious).Column
    End With
    tst = Err.Number = 0
End Function

Public Function firstRow(withinRange As Range, Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long

On Error Resume Next
    With withinRange
        firstRow = .Find("*", getCornerRange(withinRange, rightBottom), LookIn, xlPart, xlByRows, xlNext).Row
    End With
    tst = Err.Number = 0
End Function

Public Function firstCol(withinRange As Range, Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long

On Error Resume Next
    With withinRange
        firstCol = .Find("*", getCornerRange(withinRange, rightBottom), LookIn, xlPart, xlByColumns, xlNext).Column
    End With
    tst = Err.Number = 0
End Function

'gets the specified corner of a range
'left top fastest, left bottom slowest

Public Function getCornerRange(rng As Range, _
                                Optional whichCorner As cornerCell = rightBottom, _
                                Optional tst As Boolean) As Range

Dim boundsArr As Variant
Dim funcTest As Boolean
Dim lBnd As Long

tst = False
On Error GoTo exitFunc

With rng
    If .Areas.count > 1 Then
        boundsArr = getBoundsMA(rng, funcTest)
        If Not funcTest Then Exit Function
        lBnd = LBound(boundsArr)
        
        With rng.Parent
            Select Case whichCorner
                Case 0 'lefttop
                    Set getCornerRange = .Cells(boundsArr(lBnd), boundsArr(lBnd + 1))
                Case 1 'right top
                    Set getCornerRange = .Cells(boundsArr(lBnd), boundsArr(lBnd + 3))
                Case 2 'left bottom
                    Set getCornerRange = .Cells(boundsArr(lBnd + 2), boundsArr(lBnd + 1))
                Case 3 'right bottom
                    Set getCornerRange = .Cells(boundsArr(lBnd + 2), boundsArr(lBnd + 3))
            End Select
        End With
    Else
        Select Case whichCorner
            Case 0 'lefttop
                Set getCornerRange = .Cells(1)
            Case 1 'right top
                Set getCornerRange = .Cells(.Columns.count)
            Case 2 'left bottom
                Set getCornerRange = .Cells(.Cells.count - .Columns.count + 1)
            Case 3 'right bottom
                Set getCornerRange = .Cells(.Cells.count)
        End Select
    End If
End With

tst = True
exitFunc:
End Function

Public Function getBoundsMA(rng As Range, _
                        Optional tst As Boolean) As Variant
               
Dim minRow As Long, maxRow As Long, minCol As Long, maxCol As Long
Dim tArea As Range, tCell As Range

On Error GoTo exitFunc
tst = False

If rng.Areas.count = 1 Then
    With rng
        getBoundsMA = Array(.Row, .Column, .Row + .Rows.count - 1, .Column + .Columns.count - 1)
    End With
    tst = True
    Exit Function
End If

With rng.Parent
    minRow = .Rows.count + 1
    minCol = .Columns.count + 1
    maxRow = 0
    maxCol = 0
End With

For Each tArea In rng.Areas
    With tArea
        Set tCell = .Cells(.Cells.count)
        If .Row < minRow Then minRow = .Row
        If .Column < minCol Then minCol = .Column
        If tCell.Row > maxRow Then maxRow = tCell.Row
        If tCell.Column > maxCol Then maxCol = tCell.Column
    End With
Next

getBoundsMA = Array(minRow, minCol, maxRow, maxCol)
tst = True
exitFunc:
End Function

 

[BMRC]

Chirp,

Thank you so much for your reply and your ideas. I havn't gotten a chance yet to go through it, but will today.

I'll post soon with an update.

Again, I appreciate your help here.
Cheers,
BMRC