Compare 2 arrays.

MyHanhCB · Feb 20, 2023

Hello everyone in the Mrexcel forum.
I am a foreigner, specifically Vietnamese, so my English may not be fluent. Anything offensive to me sorry.
I have an array A containing 15000 values, and an array B containing 10000 values. I want to find if each value in array A is in array B or not. If not, save that value in array C (array C is the value I'm looking for).
I use this 1 piece of code in my project. But it works quite slow.
Can you guys help me with an alternative code that can work faster?. Thank you very much.

VBA Code:

Dim found As Boolean
        found = False
   o = 0
27    For i = LBound(rn1, 1) To UBound(rn1, 1)
     traRn1 = rn1(i, 1) & "#" & rn1(i, 2) & "#" & rn1(i, 3)
        For l = LBound(rn2, 1) To UBound(rn2, 1)
29     traRn2 = rn2(l, 1) & "#" & rn2(l, 2) & "#" & rn2(l, 3)
31 If traRn1 <> "##" Or traRn2 <> "##" Then
            If traRn1 = traRn2 Then
            found = True
                Exit For
                    End If
                        End If
                            Next l
33 If traRn1 <> "##" Or traRn2 <> "##" Then
            If Not found Then
                    o = o + 1
                    ReDim Preserve so(1 To o)
                    so(o) = rn1(i, 1) & "_" & rn1(i, 2)
                        End If
                            End If
                                found = False
                                    Next i

JoeMo · Feb 20, 2023

Welcome to the forum. Think this might be faster but have not tested it.

Here's another way to do what you want. I have two arrays, arA with 15 elements in col A (see below) and arB with 10 in col C.
Any element in arA that's not found in arB is placed in arC (the result array). On completion arC is written to col E starting in E2.
Here's the worksheet after the code has run. Below that is the code. You can change ranges to adapt this to your worksheet.

Book1

A

B

C

D

E

1

arA

arB

arC

2

data15

data9

data15

3

data1

data3

data13

4

data8

data1

data12

5

data5

data8

data11

6

data3

data6

data14

7

data7

data2

8

data13

data10

9

data4

data5

10

data9

data4

11

data6

data7

12

data12

13

data10

14

data2

15

data11

16

data14

Sheet6

VBA Code:

Sub FasterMaybe()
Dim arA As Variant, arB As Variant, arC As Variant, x As Variant
arA = Range("A2:A16").Value
arB = Range("C2:C11").Value
ReDim arC(1 To UBound(arA, 1), 1 To 1)
For i = 1 To UBound(arA, 1)
    x = Application.Match(arA(i, 1), arB, 0)
    If IsError(x) Then
        ct = ct + 1
        arC(ct, 1) = arA(i, 1)
    End If
Next i
If ct > 0 Then
    Range("E:E").ClearContents
    Range("E1").Value = "arC"
    Range("E2:E" & ct + 1).Value = arC
Else
    MsgBox "All values in arA can be found in arB"
End If
End Sub

MyHanhCB · Feb 20, 2023

Yes, thanks for your help. Thank you very much.

JoeMo said:
Welcome to the forum. Think this might be faster but have not tested it.

Here's another way to do what you want. I have two arrays, arA with 15 elements in col A (see below) and arB with 10 in col C.
Any element in arA that's not found in arB is placed in arC (the result array). On completion arC is written to col E starting in E2.
Here's the worksheet after the code has run. Below that is the code. You can change ranges to adapt this to your worksheet.

Book1
A B C D E
1 arA arB arC
2 data15 data9 data15
3 data1 data3 data13
4 data8 data1 data12
5 data5 data8 data11
6 data3 data6 data14
7 data7 data2
8 data13 data10
9 data4 data5
10 data9 data4
11 data6 data7
12 data12
13 data10
14 data2
15 data11
16 data14
Sheet6

VBA Code:

Sub FasterMaybe() Dim arA As Variant, arB As Variant, arC As Variant, x As Variant arA = Range("A2:A16").Value arB = Range("C2:C11").Value ReDim arC(1 To UBound(arA, 1), 1 To 1) For i = 1 To UBound(arA, 1) x = Application.Match(arA(i, 1), arB, 0) If IsError(x) Then ct = ct + 1 arC(ct, 1) = arA(i, 1) End If Next i If ct > 0 Then Range("E:E").ClearContents Range("E1").Value = "arC" Range("E2:E" & ct + 1).Value = arC Else MsgBox "All values in arA can be found in arB" End If End Sub

JoeMo · Feb 21, 2023

MyHanhCB said:
Yes, thanks for your help. Thank you very much.

You are welcome - thanks for the reply.

MyHanhCB · Feb 21, 2023

JoeMo said:
You are welcome - thanks for the reply.

I tried the Match function. But still not faster. I tried using the CountIf function, it seems more feasible, the speed is reduced to only 13s with rn1 15000 values and rn2 10000 values. Thanks for the interaction. Hope to get help in the future. <3 <3 <3

VBA Code:

i = 2
            .Range("A2").Resize(UBound(rn1, 1), 1).Value = rn1
            lr = .Range("A" & Rows.Count).End(xlUp).Row
29            For o = 1 To UBound(rn2, 1)
                If WorksheetFunction.CountIf(.Range("A2:A" & lr), rn2(o, 1)) = 0 Then
                 .Range("C" & i) = Replace(Left(rn1(o, 1), Len(rn1(o, 1)) - 2), "#", "_")
                 i = i + 1
                 End If
                    Next o

Alex Blakenburg · Feb 21, 2023

Give this a try:
PS: You might want to follow Joe's lead in providing some sample data using XL2BB. It encourages people to jump in if they don't have to spend time creating the test data. Your explanation seemed nice and clear though.

VBA Code:

Sub GetMissingValues()

    Dim shtData As Worksheet
    Dim rngListA As Range, rngListB As Range, rngMissing As Range
    Dim arrListA As Variant, arrListB As Variant, arrListMissing As Variant
    Dim rowLastListA As Long, rowLastListB As Long, i As Long, iMissing As Long
    Dim dictListB As Object, dictKey As String
    
    Set shtData = ActiveSheet                                               '<--- Change as required
    With shtData
        rowLastListA = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngListA = .Range(.Cells(2, "A"), .Cells(rowLastListA, "A"))
        arrListA = rngListA.Value
        
        rowLastListB = .Range("C" & Rows.Count).End(xlUp).Row
        Set rngListB = .Range(.Cells(2, "C"), .Cells(rowLastListB, "C"))
        arrListB = rngListB.Value
        
        Set rngMissing = .Range("E2")
        ReDim arrListMissing(1 To UBound(arrListA, 1), 1 To UBound(arrListA, 2))
    End With

    ' Load ListB into Dictionary
    Set dictListB = CreateObject("Scripting.dictionary")
    For i = 1 To UBound(arrListB)
        dictKey = arrListB(i, 1)
        If Not dictListB.exists(dictKey) Then
            dictListB(dictKey) = i
        End If
    Next i
    
    ' Loop through ListA and see if in Dictionary if not add to Missing List
    For i = 1 To UBound(arrListA)
        dictKey = arrListA(i, 1)
        If Not dictListB.exists(dictKey) Then
            iMissing = iMissing + 1
            arrListMissing(iMissing, 1) = arrListA(i, 1)
        End If
    Next i

    ' Write out missing items
    rngMissing.Resize(iMissing).Value = arrListMissing
End Sub

JoeMo · Feb 21, 2023

MyHanhCB said:
I tried the Match function. But still not faster. I tried using the CountIf function, it seems more feasible, the speed is reduced to only 13s with rn1 15000 values and rn2 10000 values. Thanks for the interaction. Hope to get help in the future. <3 <3 <3

VBA Code:

i = 2 .Range("A2").Resize(UBound(rn1, 1), 1).Value = rn1 lr = .Range("A" & Rows.Count).End(xlUp).Row 29 For o = 1 To UBound(rn2, 1) If WorksheetFunction.CountIf(.Range("A2:A" & lr), rn2(o, 1)) = 0 Then .Range("C" & i) = Replace(Left(rn1(o, 1), Len(rn1(o, 1)) - 2), "#", "_") i = i + 1 End If Next o

Just curious, how long did the code I posted take for the rn1 15000 and rn2 10000 data?

DanteAmor · Feb 21, 2023

MyHanhCB said:
with rn1 15000 values and rn2 10000 values

With the following, for 15,000 and 10,000 values the result is immediate:

VBA Code:

Sub arrays()
  Dim a, b, c
  Dim dic As Object
  Dim i&, k&
 
  a = Range("A2", Range("A" & Rows.Count).End(3)).Value
  b = Range("C2", Range("C" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(a, 1), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = Empty
  Next
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      k = k + 1
      c(k, 1) = a(i, 1)
    End If
  Next
 
  Range("E2").Resize(k).Value = c
End Sub

MyHanhCB · Feb 21, 2023

JoeMo said:
Just curious, how long did the code I posted take for the rn1 15000 and rn2 10000 data?

Yes, I tried and the time went up to 26s. I don't know where did I go wrong?

VBA Code:

Dim x As Variant, vung() As Variant
o = 0
            With ThisWorkbook.Sheets(1)
           .Range("B2").Resize(UBound(rn2, 1), 1).Value = rn2
            vung = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row).Value
            ReDim so(1 To UBound(rn1, 1), 1 To 1)
                For i = 1 To UBound(rn1, 1)
                    x = Application.Match(rn1(i, 1), vung, 0)
                        If IsError(x) Then
                            o = o + 1
                            so(o, 1) = rn1(i, 1)
                        End If
                Next i
                If o > 0 Then
                    .Range("C:C").ClearContents
                    .Range("C2:C" & o + 1).Value = so
                Else
                    MsgBox "All values in arA can be found in arB"
            
                End If
            End With

MyHanhCB · Feb 21, 2023

DanteAmor said:

With the following, for 15,000 and 10,000 values the result is immediate:

VBA Code:

Sub arrays()
  Dim a, b, c
  Dim dic As Object
  Dim i&, k&
 
  a = Range("A2", Range("A" & Rows.Count).End(3)).Value
  b = Range("C2", Range("C" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(a, 1), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = Empty
  Next
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      k = k + 1
      c(k, 1) = a(i, 1)
    End If
  Next
 
  Range("E2").Resize(k).Value = c
End Sub

Well thank you for your help. Below is my project. With little knowledge. Hope you can help.

Code:

Option Explicit
Public k, j As Integer
Sub tk()
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    'On Error GoTo ThongBao
    Dim fileExplorer As FileDialog
    Dim fileList() As String, name As String
    Dim wb As Workbook, ws As Worksheet, t&
                t = Timer
    Dim fso As Object, dic As Object, arr1(), so(), rn1() As String, rn2() As String
    Dim traRn1, traRn2 As Variant, i%, o%, l%, lr%
    Set dic = CreateObject("Scripting.Dictionary")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
If MsgBoxUni(VNItoUNICODE("Laáy Thoâng Tin SDC Chöa Kyù"), vbYesNo) = vbYes Then
    With fileExplorer
        .Title = "Local File"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "excel file", "*.xlsx"
        .InitialFileName = ""
        If .Show <> -1 Then Exit Sub
1        ReDim fileList(1 To .SelectedItems.Count)
            For i = 1 To .SelectedItems.Count
                fileList(i) = .SelectedItems(i)
            Next i
    End With
    i = 1
While i <= UBound(fileList)
        Set wb = Workbooks.Open(fileList(i))
5        Set ws = wb.Sheets(1)
      With ws
        lr = .Range("A" & Rows.Count).End(xlUp).Row
7 arr1 = .Range("B5:D" & lr).Value
If i = 1 Then ReDim rn1(1 To (UBound(arr1, 1) * UBound(fileList)), 1 To i)
If i > 1 Then ReDim Preserve rn1(1 To UBound(rn1), 1 To i)
9                For o = 1 To UBound(arr1, 1)
                    If Not dic.exists(arr1(o, 1) & "#" & arr1(o, 2) & "#" & arr1(o, 3)) Then
    k = k + 1
11    dic.Add arr1(o, 1) & "#" & arr1(o, 2) & "#" & arr1(o, 3), k
    rn1(k, 1) = arr1(o, 1) & "(" & arr1(o, 2) & ")" & "#" & arr1(o, 3) & "#" & 1
    Else
    l = dic.Item(arr1(o, 1) & "#" & arr1(o, 2) & "#" & arr1(o, 3))
    rn1(l, 1) = Left(rn1(l, 1), Len(rn1(l, 1)) - 1) & Right(rn1(l, 1), 1) + 1
                    End If
                Next o
13            wb.Close False
        End With
    i = i + 1
Wend
End If
        dic.RemoveAll: l = 0
'---------------------------------------
If MsgBoxUni(VNItoUNICODE("Laáy Thoâng Tin SDC Ñaõ Kyù"), vbYesNo) = vbYes Then
    With fileExplorer
        .Title = "Local File"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "excel file", "*.xlsx"
        .InitialFileName = ""
        If .Show <> -1 Then Exit Sub
15        ReDim fileList(1 To .SelectedItems.Count)
            For i = 1 To .SelectedItems.Count
                fileList(i) = .SelectedItems(i)
            Next i
    End With
    i = 1
While i <= UBound(fileList)
        Set wb = Workbooks.Open(fileList(i))
17        Set ws = wb.Sheets(1)
      With ws
        lr = .Range("A" & Rows.Count).End(xlUp).Row
arr1 = .Range("B5:D" & lr).Value
    If i = 1 Then ReDim rn2(1 To (UBound(arr1, 1) * UBound(fileList)), 1 To i)
    If i > 1 Then ReDim Preserve rn2(1 To UBound(rn2, 1), 1 To i)
                For o = 1 To UBound(arr1, 1)
21                    If Not dic.exists(arr1(o, 1) & "#" & arr1(o, 2) & "#" & arr1(o, 3)) Then
    j = j + 1
23    dic.Add arr1(o, 1) & "#" & arr1(o, 2) & "#" & arr1(o, 3), j
    rn2(j, 1) = arr1(o, 1) & "(" & arr1(o, 2) & ")" & "#" & arr1(o, 3) & "#" & 1
    Else
    l = dic.Item(arr1(o, 1) & "#" & arr1(o, 2) & "#" & arr1(o, 3))
    rn2(l, 1) = Left(rn2(l, 1), Len(rn2(l, 1)) - 1) & Right(rn2(l, 1), 1) + 1
                    End If
25                Next o
            wb.Close False
        End With
    i = i + 1
Wend
Else
    Exit Sub
End If
Dim x As Variant, vung() As Variant
o = 0
            With ThisWorkbook.Sheets(1)
           .Range("B2").Resize(UBound(rn2, 1), 1).Value = rn2
            vung = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row).Value
            ReDim so(1 To UBound(rn1, 1), 1 To 1)
                For i = 1 To UBound(rn1, 1)
                    x = Application.Match(rn1(i, 1), vung, 0)
                        If IsError(x) Then
                            o = o + 1
                            so(o, 1) = rn1(i, 1)
                        End If
                Next i
                If o > 0 Then
                    .Range("C:C").ClearContents
                    .Range("C2:C" & o + 1).Value = so
                Else
                    MsgBox "All values in arA can be found in arB"
            
                End If
            End With
    '--------------------------------

                    dic.RemoveAll
33    Call edit_name
     MsgBoxUni (VNItoUNICODE("Hoaøn Thaønh Thoáng Keâ")) & "   " & Timer - t & "s", vbInformation
LoiCT: k = 0:     j = 0:  Erase rn1, rn2, arr1, vung, so
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
Exit Sub
ThongBao:
 MsgBox Error, , Erl
 Resume LoiCT
End Sub

Compare 2 arrays.

MyHanhCB

New Member

Excel Facts

JoeMo

MrExcel MVP

MyHanhCB

New Member

JoeMo

MrExcel MVP

MyHanhCB

New Member

Alex Blakenburg

MrExcel MVP

JoeMo

MrExcel MVP

DanteAmor

Well-known Member

MyHanhCB

New Member

Attachments

MyHanhCB

New Member

Similar threads

Forum statistics

Share this page

Compare 2 arrays.

New Member

Excel Facts

MrExcel MVP

New Member

MrExcel MVP

New Member

MrExcel MVP

MrExcel MVP

Well-known Member

New Member

Attachments

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock