Match data columns to columns million + with scripting dictionary

S

SamKhem

Board Regular
Joined
Mar 18, 2024
Messages
50
Office Version
  1. 2016
Platform
  1. Windows
Dear Senior member
I would like you to assist as I have 4 columns data 1 to 4 and 4 columns Main 1 to Main 4. Need to matching base on data 1 to data 4 compare with Main1 to Main 4 and get result 1 to result 4 and different 1 to different 4 as sample below.
Thank for support.
Data 1Data 2Data 3Data 4Main 1Main 2Main 3Main 4Match 1Match 2Match 3Match 4Different 1Different 2Different 3Different 4
ABC-2222-123345DEF-2222-123345GHT-2222-123345NBC-2222-123345ABC-0987-89766DEF-0987-89766GHT-0987-89766NBC-0987-89766
ABC-1111-123345DEF-1111-123345GHT-1111-123345NBC-1111-123345ABC-1111-123345DEF-1111-123345GHT-1111-123345NBC-1111-123345
ABC-2222-89765DEF-2222-89765GHT-2222-89765NBC-2222-89765ABC-1285-89771DEF-1285-89771GHT-1285-89771NBC-1285-89771
ABC-0987-89766DEF-0987-89766GHT-0987-89766NBC-0987-89766ABC-2222-123345DEF-2222-123345GHT-2222-123345NBC-2222-123345
ABC-2222-89767DEF-2222-89767GHT-2222-89767NBC-2222-89767ABC-2222-89765DEF-2222-89765GHT-2222-89765NBC-2222-89765
ABC-2222-89768DEF-2222-89768GHT-2222-89768NBC-2222-89768ABC-2222-89767DEF-2222-89767GHT-2222-89767NBC-2222-89767
ABC-2222-89769DEF-2222-89769GHT-2222-89769NBC-2222-89769ABC-2222-89768DEF-2222-89768GHT-2222-89768NBC-2222-89768
ABC-2222-89770DEF-2222-89770GHT-2222-89770NBC-2222-89770ABC-2222-89769DEF-2222-89769GHT-2222-89769NBC-2222-89769
ABC-1285-89771DEF-1285-89771GHT-1285-89771NBC-1285-89771ABC-2222-89770DEF-2222-89770GHT-2222-89770NBC-2222-89770
ABC-2222-89772DEF-2222-89772GHT-2222-89772NBC-2222-89772ABC-2222-89772DEF-2222-89772GHT-2222-89772NBC-2222-89772
ABC-2222-89773DEF-2222-89773GHT-2222-89773NBC-2222-89773ABC-2222-89773DEF-2222-89773GHT-2222-89773NBC-2222-89773
ABC-2222-89774DEF-2222-89774GHT-2222-89774NBC-2222-89774ABC-2222-89774DEF-2222-89774GHT-2222-89774NBC-2222-89774
ABC-2222-89775DEF-2222-89775GHT-2222-89775NBC-2222-89775ABC-2222-89775DEF-2222-89775GHT-2222-89775NBC-2222-89775
ABC-2222-89776DEF-2222-89776GHT-2222-89776NBC-2222-89776ABC-2222-89776DEF-2222-89776GHT-2222-89776NBC-2222-89776
ABC-2222-89777DEF-2222-89777GHT-2222-89777NBC-2222-89777ABC-2222-89777DEF-2222-89777GHT-2222-89777NBC-2222-89777
ABC-2222-89778DEF-2222-89778GHT-2222-89778NBC-2222-89778ABC-2222-89778DEF-2222-89778GHT-2222-89778NBC-2222-89778
ABC-2222-89779DEF-2222-89779GHT-2222-89779NBC-2222-89779ABC-2222-89779DEF-2222-89779GHT-2222-89779NBC-2222-89779
ABC-2222-89780DEF-2222-89780GHT-2222-89780NBC-2222-89780ABC-2222-89780DEF-2222-89780GHT-2222-89780NBC-2222-89780
ABC-2222-89781DEF-2222-89781GHT-2222-89781NBC-2222-89781ABC-2222-89781DEF-2222-89781GHT-2222-89781NBC-2222-89781
ABC-2222-89782DEF-2222-89782GHT-2222-89782NBC-2222-89782ABC-2222-89782DEF-2222-89782GHT-2222-89782NBC-2222-89782
ABC-2223-89777DEF-2223-89780GHT-2223-89778NBC-1222-89781ABC-2222-89783DEF-2222-89783GHT-2222-89783NBC-2222-89783
ABC-2223-89778DEF-2223-89781GHT-2223-89779NBC-1222-89782ABC-2222-89784DEF-2222-89784GHT-2222-89784NBC-2222-89784
ABC-2223-89779GHT-2223-89780ABC-2222-89785DEF-2222-89785GHT-2222-89785NBC-2222-89785
ABC-2223-89780ABC-2222-89786DEF-2222-89786GHT-2222-89786NBC-2222-89786
ABC-2223-89781ABC-2222-89787DEF-2222-89787GHT-2222-89787NBC-2222-89787
ABC-2223-89782ABC-2222-89788DEF-2222-89788GHT-2222-89788NBC-2222-89788
ABC-2223-89783ABC-2222-89789DEF-2222-89789GHT-2222-89789NBC-2222-89789
ABC-2222-89790DEF-2222-89790GHT-2222-89790NBC-2222-89790
ABC-2222-89791DEF-2222-89791GHT-2222-89791NBC-2222-89791
ABC-2222-89792DEF-2222-89792GHT-2222-89792NBC-2222-89792
ABC-2222-89793DEF-2222-89793GHT-2222-89793NBC-2222-89793
ABC-2222-89794DEF-2222-89794GHT-2222-89794NBC-2222-89794
ABC-2222-89795DEF-2222-89795GHT-2222-89795NBC-2222-89795
ABC-2222-89796DEF-2222-89796GHT-2222-89796NBC-2222-89796
ABC-2222-89797DEF-2222-89797GHT-2222-89797NBC-2222-89797
ABC-2222-89798DEF-2222-89798GHT-2222-89798NBC-2222-89798
ABC-2222-89799DEF-2222-89799GHT-2222-89799NBC-2222-89799
ABC-2222-89800DEF-2222-89800GHT-2222-89800NBC-2222-89800
ABC-2222-89801DEF-2222-89801GHT-2222-89801NBC-2222-89801
ABC-2222-89802DEF-2222-89802GHT-2222-89802NBC-2222-89802
ABC-2222-89803DEF-2222-89803GHT-2222-89803NBC-2222-89803
ABC-2222-89804DEF-2222-89804GHT-2222-89804NBC-2222-89804
ABC-2222-89805DEF-2222-89805GHT-2222-89805NBC-2222-89805
ABC-2222-89806DEF-2222-89806GHT-2222-89806NBC-2222-89806
ABC-2222-89807DEF-2222-89807GHT-2222-89807NBC-2222-89807
ABC-2222-89808DEF-2222-89808GHT-2222-89808NBC-2222-89808
ABC-2222-89809DEF-2222-89809GHT-2222-89809NBC-2222-89809
ABC-2222-89810DEF-2222-89810GHT-2222-89810NBC-2222-89810
ABC-2222-89811DEF-2222-89811GHT-2222-89811NBC-2222-89811
ABC-2222-89812DEF-2222-89812GHT-2222-89812NBC-2222-89812
ABC-2222-89813DEF-2222-89813GHT-2222-89813NBC-2222-89813
ABC-2222-89814DEF-2222-89814GHT-2222-89814NBC-2222-89814
ABC-2222-89815DEF-2222-89815GHT-2222-89815NBC-2222-89815
ABC-2222-89816DEF-2222-89816GHT-2222-89816NBC-2222-89816
ABC-2222-89817DEF-2222-89817GHT-2222-89817NBC-2222-89817
ABC-2222-89818DEF-2222-89818GHT-2222-89818NBC-2222-89818
ABC-2222-89819DEF-2222-89819GHT-2222-89819NBC-2222-89819
ABC-2222-89820DEF-2222-89820GHT-2222-89820NBC-2222-89820
ABC-2222-89821DEF-2222-89821GHT-2222-89821NBC-2222-89821
ABC-2222-89822DEF-2222-89822GHT-2222-89822NBC-2222-89822
ABC-2222-89823DEF-2222-89823GHT-2222-89823NBC-2222-89823
ABC-2222-89824DEF-2222-89824GHT-2222-89824NBC-2222-89824
ABC-2222-89825DEF-2222-89825GHT-2222-89825NBC-2222-89825
ABC-2222-89826DEF-2222-89826GHT-2222-89826NBC-2222-89826
ABC-2222-89827DEF-2222-89827GHT-2222-89827NBC-2222-89827
ABC-2222-89828DEF-2222-89828GHT-2222-89828NBC-2222-89828
ABC-2222-89829DEF-2222-89829GHT-2222-89829NBC-2222-89829
ABC-2222-89830DEF-2222-89830GHT-2222-89830NBC-2222-89830
ABC-2222-89831DEF-2222-89831GHT-2222-89831NBC-2222-89831
ABC-2222-89832DEF-2222-89832GHT-2222-89832NBC-2222-89832
ABC-2222-89833DEF-2222-89833GHT-2222-89833NBC-2222-89833
ABC-2222-89834DEF-2222-89834GHT-2222-89834NBC-2222-89834
ABC-2222-89835DEF-2222-89835GHT-2222-89835NBC-2222-89835
ABC-2222-89836DEF-2222-89836GHT-2222-89836NBC-2222-89836
ABC-2222-89837DEF-2222-89837GHT-2222-89837NBC-2222-89837
ABC-2222-89838DEF-2222-89838GHT-2222-89838NBC-2222-89838
ABC-2222-89839DEF-2222-89839GHT-2222-89839NBC-2222-89839
ABC-2222-89840DEF-2222-89840GHT-2222-89840NBC-2222-89840
 
Sort by date Sort by votes
Fuji said:
try
Code: 
Sub test()
    Dim a, b, i&, ii&, n&, x
    With [a1].CurrentRegion.Offset(1)
        .Columns(9).Resize(, .Columns.Count - 8).ClearContents
        a = .Value
        ReDim b(1 To UBound(a, 1) * 8)
        For i = 1 To UBound(a, 1) - 1
            For ii = 5 To 8
                If a(i, ii) <> "" Then n = n + 1: b(n) = a(i, ii)
            Next
        Next
        For i = 1 To UBound(a, 1) - 1
            For ii = 1 To 4
                If a(i, ii) <> "" Then
                    x = Application.Match(a(i, ii), b, 0)
                    If IsNumeric(x) Then
                        a(UBound(a, 1), ii) = a(UBound(a, 1), ii) + 1
                        a(a(UBound(a, 1), ii), ii + 8) = a(i, ii)
                    Else
                        a(UBound(a, 1), ii + 4) = a(UBound(a, 1), ii + 4) + 1
                        a(a(UBound(a, 1), ii + 4), ii + 12) = a(i, ii)
                    End If
                End If
            Next
        Next
        .Resize(.Rows.Count - 1).Value = a
    End With
End Sub
Click to expand...
Thank so much for support Fuji. Anyway, I tried your code work work well with small data. I tried big row data it take long time to complete. Could you help this?
 
Upvote 0

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Try change to
Code: 
Sub test()
    Dim a, i&, ii&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With [a1].CurrentRegion.Offset(1)
        .Columns(9).Resize(, .Columns.Count - 8).ClearContents
        a = .Value
        ReDim b(1 To UBound(a, 1) * 8)
        For i = 1 To UBound(a, 1) - 1
            For ii = 5 To 8
                If a(i, ii) <> "" Then dic(a(i, ii)) = Empty
            Next
        Next
        For i = 1 To UBound(a, 1) - 1
            For ii = 1 To 4
                If a(i, ii) <> "" Then
                    If dic.exists(a(i, ii)) Then
                        a(UBound(a, 1), ii) = a(UBound(a, 1), ii) + 1
                        a(a(UBound(a, 1), ii), ii + 8) = a(i, ii)
                    Else
                        a(UBound(a, 1), ii + 4) = a(UBound(a, 1), ii + 4) + 1
                        a(a(UBound(a, 1), ii + 4), ii + 12) = a(i, ii)
                    End If
                End If
            Next
        Next
        .Resize(.Rows.Count - 1).Value = a
    End With
End Sub
 
Upvote 0
Fuji said:
Try change to
Code: 
Sub test()
    Dim a, i&, ii&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With [a1].CurrentRegion.Offset(1)
        .Columns(9).Resize(, .Columns.Count - 8).ClearContents
        a = .Value
        ReDim b(1 To UBound(a, 1) * 8)
        For i = 1 To UBound(a, 1) - 1
            For ii = 5 To 8
                If a(i, ii) <> "" Then dic(a(i, ii)) = Empty
            Next
        Next
        For i = 1 To UBound(a, 1) - 1
            For ii = 1 To 4
                If a(i, ii) <> "" Then
                    If dic.exists(a(i, ii)) Then
                        a(UBound(a, 1), ii) = a(UBound(a, 1), ii) + 1
                        a(a(UBound(a, 1), ii), ii + 8) = a(i, ii)
                    Else
                        a(UBound(a, 1), ii + 4) = a(UBound(a, 1), ii + 4) + 1
                        a(a(UBound(a, 1), ii + 4), ii + 12) = a(i, ii)
                    End If
                End If
            Next
        Next
        .Resize(.Rows.Count - 1).Value = a
    End With
End Sub
Click to expand...
It's still take to long for applied this code. assume I have around 1 million row for 8 columns so total around 8 million rows.
 
Upvote 0
1 million row
Click to expand...
Too much.
This is my last post here,
Code: 
Sub test()
    Dim a, c As New Collection, i&, ii&, n&, x
    With [a1].CurrentRegion.Offset(1)
        .Columns(9).Resize(, .Columns.Count - 8).ClearContents
        a = .Value: ReDim b(1 To UBound(a, 1), 1 To 8)
        On Error Resume Next
        For i = 1 To UBound(a, 1) - 1
            For ii = 5 To 8
                If a(i, ii) <> "" Then c.Add ii, CStr(a(i, ii))
            Next
        Next
        On Error GoTo 0
        For i = 1 To UBound(a, 1) - 1
            For ii = 1 To 4
                If a(i, ii) <> "" Then
                    On Error Resume Next
                    x = c(a(i, ii))
                    If Err = 0 Then
                        n = b(UBound(b, 1), ii) + 1
                        b(n, ii) = a(i, ii)
                        b(UBound(b, 1), ii) = n
                    Else
                        n = b(UBound(a, 1), ii + 4) + 1
                        b(n, ii + 4) = a(i, ii)
                        b(UBound(b, 1), ii + 4) = n
                    End If
                    Err.Clear
                End If
            Next
        Next
        .Columns(9).Resize(UBound(b, 1) - 1, UBound(b, 2)) = b
    End With
End Sub
 
Upvote 0
Thanks for try to support. Let me try again. Have a nice weekend.
 
Upvote 0
@SamKhem
1. Are data in each column unique?
2. Is it ok to sort data in each column?
 
Upvote 0
Try this:
I only include Data1 & Main1 to test the speed. Please, check & show us the completion time in immediate windows. If it's fast enough then I'll write the complete code.
VBA Code: 
Sub SamKhem_1()
Dim i As Long, j As Long, n As Long, a As Long, b As Long, k As Long
Dim va, vb, vc

Application.ScreenUpdating = False
t = Timer
x = 1

Columns(x).Sort Key1:=Cells(1, x), Order1:=xlAscending, Header:=xlYes
Columns(x + 4).Sort Key1:=Cells(1, x + 4), Order1:=xlAscending, Header:=xlYes

a = Cells(Rows.Count, 1).End(xlUp).Row
b = Cells(Rows.Count, x + 4).End(xlUp).Row

va = Range(Cells(2, x), Cells(a, x))
vb = Range(Cells(2, x + 4), Cells(b, x + 4))

ReDim vc(1 To UBound(va, 1), 1 To 1)
n = 1
For i = 1 To UBound(va, 1)
    For j = n To UBound(vb, 1)
        If va(i, 1) = vb(j, 1) Then
            k = k + 1
            vc(k, 1) = va(i, 1)
            va(i, 1) = ""
            n = j
            Exit For
        ElseIf va(i, 1) < vb(j, 1) Then
            n = j
            Exit For
        End If
    Next
Next


Cells(2, x + 8).Resize(UBound(vc, 1), 1) = vc
Cells(2, x + 12).Resize(UBound(va, 1), 1) = va
Columns(x + 12).Sort Key1:=Cells(1, x + 12), Order1:=xlAscending, Header:=xlYes

Application.ScreenUpdating = True
Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"

End Sub

SamKhem - Match data columns to columns million.xlsm
ABCDEFGHIJKLM
1Data1Main 1Match 1Different 1
2ABC098789766ABC098789766ABC098789766ABC222389780
3ABC1111123345ABC1111123345ABC1111123345ABC222389781
4ABC2222123345ABC128589771ABC2222123345ABC222389782
5ABC222289765ABC2222123345ABC222289765ABC222389783
6ABC222289767ABC222289765ABC222289767
7ABC222289768ABC222289767ABC222289768
8ABC222389780ABC222289768
9ABC222389781ABC222289769
10ABC222389782ABC222289770
11ABC222389783ABC222289772
Sheet1
 
Upvote 0
Akuini said:
Try this:
I only include Data1 & Main1 to test the speed. Please, check & show us the completion time in immediate windows. If it's fast enough then I'll write the complete code.
VBA Code: 
Sub SamKhem_1()
Dim i As Long, j As Long, n As Long, a As Long, b As Long, k As Long
Dim va, vb, vc

Application.ScreenUpdating = False
t = Timer
x = 1

Columns(x).Sort Key1:=Cells(1, x), Order1:=xlAscending, Header:=xlYes
Columns(x + 4).Sort Key1:=Cells(1, x + 4), Order1:=xlAscending, Header:=xlYes

a = Cells(Rows.Count, 1).End(xlUp).Row
b = Cells(Rows.Count, x + 4).End(xlUp).Row

va = Range(Cells(2, x), Cells(a, x))
vb = Range(Cells(2, x + 4), Cells(b, x + 4))

ReDim vc(1 To UBound(va, 1), 1 To 1)
n = 1
For i = 1 To UBound(va, 1)
    For j = n To UBound(vb, 1)
        If va(i, 1) = vb(j, 1) Then
            k = k + 1
            vc(k, 1) = va(i, 1)
            va(i, 1) = ""
            n = j
            Exit For
        ElseIf va(i, 1) < vb(j, 1) Then
            n = j
            Exit For
        End If
    Next
Next


Cells(2, x + 8).Resize(UBound(vc, 1), 1) = vc
Cells(2, x + 12).Resize(UBound(va, 1), 1) = va
Columns(x + 12).Sort Key1:=Cells(1, x + 12), Order1:=xlAscending, Header:=xlYes

Application.ScreenUpdating = True
Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"

End Sub

SamKhem - Match data columns to columns million.xlsm
ABCDEFGHIJKLM
1Data1Main 1Match 1Different 1
2ABC098789766ABC098789766ABC098789766ABC222389780
3ABC1111123345ABC1111123345ABC1111123345ABC222389781
4ABC2222123345ABC128589771ABC2222123345ABC222389782
5ABC222289765ABC2222123345ABC222289765ABC222389783
6ABC222289767ABC222289765ABC222289767
7ABC222289768ABC222289767ABC222289768
8ABC222389780ABC222289768
9ABC222389781ABC222289769
10ABC222389782ABC222289770
11ABC222389783ABC222289772
Sheet1
Click to expand...
Thanks and let me try and inform you.
 
Upvote 0
Fuji said:
Too much.
This is my last post here,
Code: 
Sub test()
    Dim a, c As New Collection, i&, ii&, n&, x
    With [a1].CurrentRegion.Offset(1)
        .Columns(9).Resize(, .Columns.Count - 8).ClearContents
        a = .Value: ReDim b(1 To UBound(a, 1), 1 To 8)
        On Error Resume Next
        For i = 1 To UBound(a, 1) - 1
            For ii = 5 To 8
                If a(i, ii) <> "" Then c.Add ii, CStr(a(i, ii))
            Next
        Next
        On Error GoTo 0
        For i = 1 To UBound(a, 1) - 1
            For ii = 1 To 4
                If a(i, ii) <> "" Then
                    On Error Resume Next
                    x = c(a(i, ii))
                    If Err = 0 Then
                        n = b(UBound(b, 1), ii) + 1
                        b(n, ii) = a(i, ii)
                        b(UBound(b, 1), ii) = n
                    Else
                        n = b(UBound(a, 1), ii + 4) + 1
                        b(n, ii + 4) = a(i, ii)
                        b(UBound(b, 1), ii + 4) = n
                    End If
                    Err.Clear
                End If
            Next
        Next
        .Columns(9).Resize(UBound(b, 1) - 1, UBound(b, 2)) = b
    End With
End Sub
Click to expand...
Dear Fuji, I tried this code work much faster. Thanks
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Match WorkSheets back to a Master Worksheet with current years data on it.
Replies
3
Views
451
mumps
mumps
L
  • Question
change code match data based on one column instead of three columns
Replies
1
Views
359
leap out
L
A
  • Solved
transpose data for each sheet based on multiple prices
2
Replies
10
Views
321
abdo meghari
A
A
  • Question
Finding 2 or more matches in different columns and row - Excel 2003
Replies
9
Views
322
adnan_003
A
E
  • Locked
  • Question
Find duplicates and copy offset to other sheet (Second Post)
Replies
1
Views
362
Fluff
Fluff

Forum statistics

Threads
1,221,310
Messages
6,159,176
Members
451,543
Latest member
cesymcox

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top