Dirk Wessels macros

T

teodormircea

Active Member
Joined
Jan 8, 2008
Messages
331
I'm using Dirk Wessels' excel list compare .It works nice but it doesn't match evry thing, for example if i have more then 10000 lines and diferents format cell doesn't work anymore. I have the code. Does any one tryed to improuve this solution:eek:
 
Sort by date Sort by votes
OK, now I understand the problem...

I need to go offline pretty soon, so I will post the code tomorrow.
Do you still need to use a UserForm?
Is it OK to use InputBox that you can click the cell to set the range like refedit control?
 
Upvote 0

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
OK
Let's see if this works
Code: 
Sub test()
Dim dic1 As Object, dic2 As Object, e
Dim MatchA(), MatchB(), MatchAWithin(), MatchBwithin(), NoMatchWithA(), NoMatchWithB()
Dim ma As Long, mb As Long, maw As Long, mbw As Long, nma As Long, nmb As Long
Dim rng1 As Range, rng2 As Range
Dim a, i As Long, ii As Long, txt As String, ub As Integer
On Error Resume Next
Set rng1 = Application.InputBox("Select 1st Data Area", Type:=8)
Set rng2 = Application.InputBox("Select 2nd Data Area", Type:=8)
On Error GoTo 0
If (rng1 Is Nothing) + (rng2 Is Nothing) + (rng1.Columns.Count <> rng2.Columns.Count) Then Exit Sub
Set dic1 = CreateObject("scripting.dictionary")
dic1.comparemode = vbTextCompare
Set dic2 = CreateObject("scripting.dictionary")
dic2.comparemode = vbTextCompare
a = rng1.Value: ub = UBound(a, 2)
ReDim MatchAWithin(1 To UBound(a, 1), 1 To ub)
maw = 1: MatchAWithin(1, 1) = "Duplicates within Data1"
For i = 1 To UBound(a, 1)
    For ii = 1 To ub
        txt = txt & ";;" & a(i, ii)
    Next
    If Not dic1.exists(txt) Then
        dic1.Add txt, Nothing
    Else
        maw = maw + 1
        For ii = 1 To ub: MatchAWithin(maw, ii) = a(i, ii): Next
    End If
    txt = ""
Next
a = rng2.Value
ReDim MatchBwithin(1 To UBound(a, 1), 1 To ub)
mbw = 1: MatchBwithin(1, 1) = "Duplicates within Data2"
For i = 1 To UBound(a, 1)
    For ii = 1 To ub
        txt = txt & ";;" & a(i, ii)
    Next
    If Not dic2.exists(txt) Then
        dic2.Add txt, Nothing
    Else
        mbw = mbw + 1
        For ii = 1 To ub: MatchBwithin(mbw, ii) = a(i, ii): Next
    End If
    txt = ""
Next
ReDim NoMatchWithA(1 To dic1.Count + 1, 1 To ub)
nma = 1: NoMatchWithA(1, 1) = "No match with Data1"
ReDim MatchA(1 To dic1.Count + 1, 1 To ub)
ma = 1: MatchA(1, 1) = "Match with Data2"
For Each e In dic2.keys
    x = Split(Mid$(e, 3), ";;")
    If dic1.exists(e) Then
        ma = ma + 1
        For i = 0 To UBound(x): MatchA(ma, i + 1) = x(i): Next
    Else
        nma = nma + 1
        For i = 0 To UBound(x): NoMatchWithA(nma, i + 1) = x(i): Next
    End If
Next
ReDim NoMatchWithB(1 To dic2.Count, 1 To ub)
nmb = 1: NoMatchWithB(1, 1) = "No match with Data2"
ReDim MatchB(1 To dic2.Count + 1, 1 To ub)
mb = 1: MatchB(1, 1) = "Match with Data1"
For Each e In dic1.keys
    x = Split(Mid$(e, 3), ";;")
    If dic2.exists(e) Then
        mb = mb + 1
        For i = 0 To UBound(x): MatchB(mb, i + 1) = x(i): Next
    Else
        nmb = nmb + 1
        For i = 0 To UBound(x): NoMatchWithB(nmb, i + 1) = x(i): Next
    End If
Next
With Range("j1")
    .Resize(, ub * 2 + 1).EntireColumn.Clear
    With .Resize(ma, ub)
        .Value = MatchA
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(ma + 1).Resize(maw, ub)
        .Value = MatchAWithin
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(ma + maw + 2).Resize(nmb, ub)
        .Value = NoMatchWithB
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(, ub + 1)
        With .Resize(mb, ub)
            .Value = MatchB
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
        With .Offset(mb + 1).Resize(mbw, ub)
            .Value = MatchBwithin
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
        With .Offset(mb + mbw + 2).Resize(nma, ub)
            .Value = NoMatchWithA
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
    End With
End With
End Sub
 
Upvote 0
The code does:
1) ask 1st data range to select (select whole range for data1)
2) ask 2nd data range to select (select whole range for data2)
3) compares line against lines
i.e.
when data1, data2 has 3 columns, (Col.A,B,C for 1st, D,E,F for 2nd)
Take 1st line from data1 and compare with all the lines in data1 and data2
to find out duplicate/matched/non-matched lines and same thing to data2/data1.

So you will need to select the ranges with same columns size, otherwise it doesn't run.

am I missing something ?
 
Upvote 0
Yes you are right about chosing ranges, but i want to have the posibility of chosing my criteria for exemple i want to chose colA and Col D and match the 2 ranges of data using this criteria only (i can chose what ever col i want with the condition to have 2 distincts one for each range of data), and because i'm using like criteria only one col for each size i dont need to have the same size , i can even have the blank space in the columns used like criteria.
I want only to compare only 2 column 1 for each side of range
and then copy the 2 ranges and sort them by MATCH and No Match
ex A1B1C is a MATCH WITH D1E1F1 because this 2 ranges thay have commun element in A1 and D1
and copy the ranges in a new sheet put am extra column between this 2 ranges like an index and wright MATCH or No Match
 
Last edited:
Upvote 0
OK you only need one column for each range to compare with.
So, 2 ranges don't need to have same column size...
When you asked "Enter n th col ref from the left for 1st/2nd data", enter 1 for 1st, 2 for 2nd dolumn from the left of each range...
Code: 
Sub test()
Dim dic1 As Object, dic2 As Object, e, x
Dim MatchA(), MatchB(), MatchAWithin(), MatchBwithin(), NoMatchWithA(), NoMatchWithB()
Dim ma As Long, mb As Long, maw As Long, mbw As Long, nma As Long, nmb As Long
Dim rng1 As Range, rng2 As Range
Dim a, i As Long, ii As Long, txt As String, ubMax As Long, ub As Integer
On Error Resume Next
Set rng1 = Application.InputBox("Select 1st Data Area", Type:=8)
Col1 = Application.InputBox("Enter n th col ref from the left for 1st data", Type:=1)
Set rng2 = Application.InputBox("Select 2nd Data Area", Type:=8)
Col2 = Application.InputBox("Enter n th col ref from the left for 2nd data", Type:=1)
On Error GoTo 0
If (rng1 Is Nothing) + (rng2 Is Nothing) Then Exit Sub
Set dic1 = CreateObject("scripting.dictionary")
dic1.comparemode = vbTextCompare
Set dic2 = CreateObject("scripting.dictionary")
dic2.comparemode = vbTextCompare
a = rng1.Value: ubMax= UBound(a,1)) : ub = UBound(a, 2)
ReDim MatchAWithin(1 To ubMax, 1 To ub)
maw = 1: MatchAWithin(1, 1) = "Duplicates within Data1"
For i = 1 To UBound(a, 1)
    For ii = 1 To ub
        txt = txt & ";;" & a(i, ii)
    Next
    If Not dic1.exists(a(i, Col1)) Then
        dic1.Add a(i, Col1), txt
    Else
        maw = maw + 1
        For ii = 1 To ub: MatchAWithin(maw, ii) = a(i, ii): Next
    End If
    txt = ""
Next
a = rng2.Value : ubMax = WorksheetFunction.Max(ubMax, UBound(a,1))
ReDim MatchBwithin(1 To UBound(a,1), 1 To ub)
mbw = 1: MatchBwithin(1, 1) = "Duplicates within Data2"
For i = 1 To UBound(a, 1)
    For ii = 1 To ub
        txt = txt & ";;" & a(i, ii)
    Next
    If Not dic2.exists(a(i, Col2)) Then
        dic2.Add a(i, Col2), txt
    Else
        mbw = mbw + 1
        For ii = 1 To ub: MatchBwithin(mbw, ii) = a(i, ii): Next
    End If
    txt = ""
Next
ReDim NoMatchWithA(1 To ubMax, 1 To ub)
nma = 1: NoMatchWithA(1, 1) = "No match with Data1"
ReDim MatchA(1 To ubMax, 1 To ub)
ma = 1: MatchA(1, 1) = "Match with Data2"
For Each e In dic2.keys
    x = Split(Mid$(dic2(e), 3), ";;")
    If dic1.exists(e) Then
        ma = ma + 1
        For i = 0 To UBound(x): MatchA(ma, i + 1) = x(i): Next
    Else
        nma = nma + 1
        For i = 0 To UBound(x): NoMatchWithA(nma, i + 1) = x(i): Next
    End If
Next
ReDim NoMatchWithB(1 To ubMax, 1 To ub)
nmb = 1: NoMatchWithB(1, 1) = "No match with Data2"
ReDim MatchB(1 To ubMax, 1 To ub)
mb = 1: MatchB(1, 1) = "Match with Data1"
For Each e In dic1.keys
    x = Split(Mid$(dic1(e), 3), ";;")
    If dic2.exists(e) Then
        mb = mb + 1
        For i = 0 To UBound(x): MatchB(mb, i + 1) = x(i): Next
    Else
        nmb = nmb + 1
        For i = 0 To UBound(x): NoMatchWithB(nmb, i + 1) = x(i): Next
    End If
Next
With Range("j1")
    .Resize(, ub * 2 + 1).EntireColumn.Clear
    With .Resize(ma, ub)
        .Value = MatchA
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(ma + 1).Resize(maw, ub)
        .Value = MatchAWithin
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(ma + maw + 2).Resize(nmb, ub)
        .Value = NoMatchWithB
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(, ub + 1)
        With .Resize(mb, ub)
            .Value = MatchB
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
        With .Offset(mb + 1).Resize(mbw, ub)
            .Value = MatchBwithin
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
        With .Offset(mb + mbw + 2).Resize(nma, ub)
            .Value = NoMatchWithA
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
    End With
End With
End Sub
 
Upvote 0
correction
Code: 
Sub test()
Dim dic1 As Object, dic2 As Object, e, x
Dim MatchA(), MatchB(), MatchAWithin(), MatchBwithin(), NoMatchWithA(), NoMatchWithB()
Dim ma As Long, mb As Long, maw As Long, mbw As Long, nma As Long, nmb As Long
Dim rng1 As Range, rng2 As Range
Dim a, i As Long, ii As Long, txt As String, ubMax As Long, ub As Integer
On Error Resume Next
Set rng1 = Application.InputBox("Select 1st Data Area", Type:=8)
Col1 = Application.InputBox("Enter n th col ref from the left for 1st data", Type:=1)
Set rng2 = Application.InputBox("Select 2nd Data Area", Type:=8)
Col2 = Application.InputBox("Enter n th col ref from the left for 2nd data", Type:=1)
On Error GoTo 0
If (rng1 Is Nothing) + (rng2 Is Nothing) Then Exit Sub
Set dic1 = CreateObject("scripting.dictionary")
dic1.comparemode = vbTextCompare
Set dic2 = CreateObject("scripting.dictionary")
dic2.comparemode = vbTextCompare
a = rng1.Value: ubMax = UBound(a, 1): ub = UBound(a, 2)
ReDim MatchAWithin(1 To ubMax, 1 To ub)
maw = 1: MatchAWithin(1, 1) = "Duplicates within Data1"
For i = 1 To UBound(a, 1)
    For ii = 1 To ub
        txt = txt & ";;" & a(i, ii)
    Next
    If Not dic1.exists(a(i, Col1)) Then
        dic1.Add a(i, Col1), txt
    Else
        maw = maw + 1
        For ii = 1 To ub: MatchAWithin(maw, ii) = a(i, ii): Next
    End If
    txt = ""
Next
a = rng2.Value: ubMax = WorksheetFunction.Max(ubMax, UBound(a, 1))
ReDim MatchBwithin(1 To UBound(a, 1), 1 To ub)
mbw = 1: MatchBwithin(1, 1) = "Duplicates within Data2"
For i = 1 To UBound(a, 1)
    For ii = 1 To UBound(a, 2)
        txt = txt & ";;" & a(i, ii)
    Next
    If Not dic2.exists(a(i, Col2)) Then
        dic2.Add a(i, Col2), txt
    Else
        mbw = mbw + 1
        For ii = 1 To UBound(a, 2): MatchBwithin(mbw, ii) = a(i, ii): Next
    End If
    txt = ""
Next
ReDim NoMatchWithA(1 To ubMax, 1 To ub)
nma = 1: NoMatchWithA(1, 1) = "No match with Data1"
ReDim MatchA(1 To ubMax, 1 To ub)
ma = 1: MatchA(1, 1) = "Match with Data2"
For Each e In dic2.keys
    x = Split(Mid$(dic2(e), 3), ";;")
    If dic1.exists(e) Then
        ma = ma + 1
        For i = 0 To UBound(x): MatchA(ma, i + 1) = x(i): Next
    Else
        nma = nma + 1
        For i = 0 To UBound(x): NoMatchWithA(nma, i + 1) = x(i): Next
    End If
Next
ReDim NoMatchWithB(1 To ubMax, 1 To ub)
nmb = 1: NoMatchWithB(1, 1) = "No match with Data2"
ReDim MatchB(1 To ubMax, 1 To ub)
mb = 1: MatchB(1, 1) = "Match with Data1"
For Each e In dic1.keys
    x = Split(Mid$(dic1(e), 3), ";;")
    If dic2.exists(e) Then
        mb = mb + 1
        For i = 0 To UBound(x): MatchB(mb, i + 1) = x(i): Next
    Else
        nmb = nmb + 1
        For i = 0 To UBound(x): NoMatchWithB(nmb, i + 1) = x(i): Next
    End If
Next
With Range("j1")
    .Resize(, ub * 2 + 1).EntireColumn.Clear
    With .Resize(ma, ub)
        .Value = MatchA
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(ma + 1).Resize(maw, ub)
        .Value = MatchAWithin
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(ma + maw + 2).Resize(nmb, ub)
        .Value = NoMatchWithB
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin
    End With
    With .Offset(, ub + 1)
        With .Resize(mb, ub)
            .Value = MatchB
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
        With .Offset(mb + 1).Resize(mbw, ub)
            .Value = MatchBwithin
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
        With .Offset(mb + mbw + 2).Resize(nma, ub)
            .Value = NoMatchWithA
            .Borders.Weight = xlHairline
            .BorderAround Weight:=xlThin
        End With
    End With
End With
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
VLOOKUP or similar to cut/paste data
Replies
3
Views
201
kvsrinivasamurthy
K
C
  • Question
Comparing 3 tables to a list of numbers, if match, return 4 columns worth of data on another tab
Replies
4
Views
158
alansidman
A
S
  • Solved
Formula for pulling the counts on items in i different locations but with same name
2
Replies
11
Views
245
svis89
S
K
  • Solved
Prevent Workbook_Open macro from running on opening
Replies
7
Views
292
Peter_SSs
Peter_SSs
Richard1982
  • Solved
=SUMIF() question : can the criteria be a range of things?
Replies
9
Views
188
arthurbr
arthurbr

Forum statistics

Threads
1,216,106
Messages
6,128,863
Members
449,473
Latest member
soumyahalder4

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