Improve VBA to compair columns and show difference in another sheet

jbesclapez · Dec 19, 2019

Dear Mr and Mme Excel,

I have a script that I did (or took) a year ago but it is running super slow and I end up killing Excel (none of your family member Mr Excel!)

I have 2 sheets that should be idential with columns A to G. My Script is devided into 2 tasks. The first one orders the data and the second compairs.

Script 1 :
I add a column in A that concatenates B:G and then i sort by alphabetical order. So I sort on column A. Each line is unique.
Script 2:
That is the slow one. The one I need help.
I want it to compair A and B and to show what exist in A and not in B but also what exist in B and not in A. All this should show in sheet3:

VBA Code:

     Dim rngCell As Range
     For Each rngCell In sht1.Range("A2:A" & LastRowAsht1)
         If WorksheetFunction.CountIf(sht2.Range("A2:A" & LastRowAsht2), rngCell) = 0 Then
             sht3.Range("A" & Rows.Count).End(xlUp).Offset(1) = rngCell
         End If
     Next
     For Each rngCell In sht2.Range("A2:A" & LastRowAsht2)
         If WorksheetFunction.CountIf(sht1.Range("A2:A" & LastRowAsht1), rngCell) = 0 Then
             sht3.Range("B" & Rows.Count).End(xlUp).Offset(1) = rngCell
         End If
     Next

Can you find a way to make this a lot faster? As I was saying, if you compare only the first column it should be fine....

Thanks !

DanteAmor · Dec 19, 2019

Hi:
How many records do you have on each sheet and how long does the process take?

Try this and comment.

The macro takes the values from column A to G. It is not necessary to concatenate or sort the data in column A, the macro does it internally.

VBA Code:

Sub compair_columns()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, v As Variant
  Dim dic As Object, i As Long, cad As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Sheet3")
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = sh1.Range("A2:G" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2
  b = sh2.Range("A2:G" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  
  dic("exist in A and not in B") = "exist in A and not in B"
  For i = 1 To UBound(a, 1)
    cad = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7)
    dic(LCase(cad)) = cad
  Next
  
  dic("exist in B and not in A") = "exist in B and not in A"
  For i = 1 To UBound(b, 1)
    cad = b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 6) & "|" & b(i, 7)
    If dic.exists(LCase(cad)) Then
      dic.Remove LCase(cad)
    Else
      dic(LCase(cad)) = cad
    End If
  Next
  sh3.Range("A2").Resize(dic.Count, 1).Value = Application.Transpose(dic.items)
  sh3.Range("A2:A" & dic.Count + 1).TextToColumns Destination:=sh3.Range("A2"), OtherChar:="|"
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

jbesclapez · Dec 19, 2019

DanteAmor said:

Hi:
How many records do you have on each sheet and how long does the process take?

Try this and comment.

The macro takes the values from column A to G. It is not necessary to concatenate or sort the data in column A, the macro does it internally.

VBA Code:

Sub compair_columns()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, v As Variant
  Dim dic As Object, i As Long, cad As String
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Sheet3")
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = sh1.Range("A2:G" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2
  b = sh2.Range("A2:G" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
 
  dic("exist in A and not in B") = "exist in A and not in B"
  For i = 1 To UBound(a, 1)
    cad = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7)
    dic(LCase(cad)) = cad
  Next
 
  dic("exist in B and not in A") = "exist in B and not in A"
  For i = 1 To UBound(b, 1)
    cad = b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 6) & "|" & b(i, 7)
    If dic.exists(LCase(cad)) Then
      dic.Remove LCase(cad)
    Else
      dic(LCase(cad)) = cad
    End If
  Next
  sh3.Range("A2").Resize(dic.Count, 1).Value = Application.Transpose(dic.items)
  sh3.Range("A2:A" & dic.Count + 1).TextToColumns Destination:=sh3.Range("A2"), OtherChar:="|"
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

Thanks for your reply. Your script is a lot faster.

Can you have a look at mine please as in theory it does what I want... whereas yours is not exactly like expected.
The first part will help you see exactly what I do and the botom part where I wrote ' '' SEARCH FOR DIFFERENCES should show the expected results.

VBA Code:

Sub copymismatches()
    ' set the workbooks
    Dim LastRowAsht1 As Long
    Dim LastRowAsht2 As Long
    Set sht1 = ActiveWorkbook.Sheets("Sheet1")
    Set sht2 = ActiveWorkbook.Sheets("Sheet2")
    Set sht3 = ActiveWorkbook.Sheets("Sheet3")
    LastRowAsht1 = sht1.Cells(Rows.Count, 1).End(xlUp).Row
    LastRowAsht2 = sht2.Cells(Rows.Count, 1).End(xlUp).Row
    
    sht3.Range("A:F").ClearContents
    
    ' Checks if at least the worksheets have the amount of lines
    If LastRowAsht1 <> LastRowAsht2 Then
    MsgBox "The amount of line is both sheet is different. It makes the macro useless"
    End If
    
''' PREPARE SHEET 1
    ' Create a column A with unique data for comparison and sort it
    sht1.Activate
    sht1.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   ' sht1.Range("A4").FormulaR1C1 = "=""PROF--""&RC[1]&""--TIME--""&RC[2]&""--DESC--""&RC[6]&""--ACC--""&RC[3]"
    sht1.Range("A4").FormulaR1C1 = "=""PROF--""&RC[1]&""--TIME--""&RC[2]&""--DESC--""&RC[6]&""--ACC--""&RC[3]&""--D--""&RC[4]&""--C--""&RC[5]"

    sht1.Range("A4").AutoFill Destination:=Range("A4:A" & LastRowAsht1)
   
   
    'Copy column A as value
    sht1.Range("A:A").Copy
    sht1.Range("A:A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    'Sort ColumnA
'     With sht1.Sort
'    .SortFields.Clear
'    .SortFields.Add2 Key:=Range("A4:A" & LastRowAsht1), Order:=xlAscending
'        .SetRange Range("A4:G" & LastRowAsht1)
'        .Header = xlYes
'        .Apply
'    End With
        
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range( _
        "A4:A" & LastRowAsht1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A3:G" & LastRowAsht1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
          
        
        
        

''' PREPARE SHEET 2
    ' Create a column A with unique data for comparison and sort it
    sht2.Activate
    sht2.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    sht2.Range("A4").FormulaR1C1 = "=""PROF--""&RC[1]&""--TIME--""&RC[2]&""--DESC--""&RC[6]&""--ACC--""&RC[3]&""--D--""&RC[4]&""--C--""&RC[5]"
    sht2.Range("A4").AutoFill Destination:=Range("A4:A" & LastRowAsht2)
    
    'Copy column A as value
    sht2.Range("A:A").Copy
    sht2.Range("A:A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    'Sort ColumnA
'     With sht2.Sort
'    .SortFields.Clear
'    .SortFields.Add2 Key:=Range("A4:A" & LastRowAsht2), Order:=xlAscending
'        .SetRange Range("A4:G" & LastRowAsht2)
'        .Header = xlYes
'        .Apply
'     End With
   
   
   
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add2 Key:=Range( _
        "A4:A" & LastRowAsht2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A3:G" & LastRowAsht2)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
   
 
' '' SEARCH FOR DIFFERENCES
'     Dim rngCell As Range
'     For Each rngCell In sht1.Range("A2:A" & LastRowAsht1)
'         If WorksheetFunction.CountIf(sht2.Range("A2:A" & LastRowAsht2), rngCell) = 0 Then
'             sht3.Range("A" & Rows.Count).End(xlUp).Offset(1) = rngCell
'         End If
'     Next
'     For Each rngCell In sht2.Range("A2:A" & LastRowAsht2)
'         If WorksheetFunction.CountIf(sht1.Range("A2:A" & LastRowAsht1), rngCell) = 0 Then
'             sht3.Range("B" & Rows.Count).End(xlUp).Offset(1) = rngCell
'         End If
'     Next
    
    
  '' CLEARS THE ADDED COLUMNS
'sht1.Columns("A").Delete
'sht2.Columns("A").Delete
    
    
    
End Sub

DanteAmor · Dec 19, 2019

It would be easier if you explain to me with examples what you need and gladly prepare the macro to do what you need.

Also comment: How many records do you have on each sheet and how long does the process take?

DanteAmor · Dec 19, 2019

You can use the xl2bb tool to put the examples.
It can be that simple:

Book1

A

B

C

D

E

F

G

1

A

B

C

D

E

F

G

2

X

B2

C2

D2

E2

F2

G2

3

A3

X

C3

D3

E3

F3

G3

4

A4

B4

C4

D4

E4

F4

G4

5

A5

B5

C5

D5

E5

F5

G5

Sheet1

Book1

A

B

C

D

E

F

G

1

A

B

C

D

E

F

G

2

A2

B2

C2

D2

E2

F2

G2

3

A3

B3

C3

D3

E3

F3

G3

4

A4

Y

C4

D4

E4

Y

G4

5

A5

B5

C5

D5

E5

F5

G5

Sheet2

Result:

Book1

A

B

C

D

E

F

G

1

2

exist in A not in B

3

X

B2

C2

D2

E2

F2

G2

4

A3

X

C3

D3

E3

F3

G3

5

A4

B4

C4

D4

E4

F4

G4

6

exist in B not in A

7

A2

B2

C2

D2

E2

F2

G2

8

A3

B3

C3

D3

E3

F3

G3

9

A4

Y

C4

D4

E4

Y

G4

Sheet3

Try again with this:

VBA Code:

Sub compair_columns()
  Dim a As Variant, b As Variant, dic As Object, i As Long, cad As String
  Set dic = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2:G" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row).Value2
  b = Sheets("Sheet2").Range("A2:G" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row).Value2
  
  dic("msg1") = "exist in A not in B"
  For i = 1 To UBound(a, 1)
    cad = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7)
    dic(LCase(cad)) = cad
  Next
  dic("msg2") = "exist in B not in A"
  For i = 1 To UBound(b, 1)
    cad = b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 6) & "|" & b(i, 7)
    If dic.exists(LCase(cad)) Then dic.Remove LCase(cad) Else dic(LCase(cad)) = cad
  Next
  
  Sheets("Sheet3").Cells.Clear
  Sheets("Sheet3").Range("A2").Resize(dic.Count, 1).Value = Application.Transpose(dic.items)
  Sheets("Sheet3").Range("A2:A" & dic.Count + 1).TextToColumns Destination:=Sheets("Sheet3").Range("A2"), _
    DataType:=xlDelimited, TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|"
  MsgBox "Done"
End Sub

jbesclapez · Dec 20, 2019

DanteAmor said:
It would be easier if you explain to me with examples what you need and gladly prepare the macro to do what you need.

Also comment: How many records do you have on each sheet and how long does the process take?

Hi DanteAmor and once again thanks for your time. Here is more info

The macro will compair Data1 and Data2 and show the differences in the 2 other columns. You see here the expected result.
All line in Data1 and Data2 are unique.
If you can provide this code (which I believe is not too far from the one in my first post) I will be able to tweak it on my side to fit in my global macro.

And to answer your question, I will have around 100 000 lines in Data1 and Data2.

Have a good day

DanteAmor · Dec 20, 2019

I thought that with my examples in post#5 you could put examples of real structure of your sheets.

With the images you put I will have to assume that Data1 is in column A, Data2 in column B and the results you want in columns C and D, all on the same sheet.

If the above is correct. The correct result would be:

Book1

A

B

C

D

1

DATA1

DATA2

In Data1 not in Data2

In Data2 not in Data1

2

CAT1

Cat1

FISH2

Fish1

3

FISH2

Fish1

Lion4

Lion5

4

Bird3

Tiger5

5

Lion4

Lion5

6

Tiger5

Sheet1a

Try this:

VBA Code:

Sub compair_columns()
  Dim a() As Variant, b() As Variant, c() As Variant, dic As Object, i As Long, j As Long
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  
  a = Range("A2:A" & Range("A" & Rows.count).End(xlUp).Row).Value2
  b = Range("B2:B" & Range("B" & Rows.count).End(xlUp).Row).Value2
  
  ReDim c(1 To UBound(b), 1 To 1)
  j = 1
  For i = 1 To UBound(a, 1)
    dic(a(i, 1)) = Empty
  Next
  For i = 1 To UBound(b, 1)
    If dic.exists(b(i, 1)) Then dic.Remove b(i, 1) Else c(j, 1) = b(i, 1): j = j + 1
  Next
  
  Range("C2").Resize(dic.count, 1).Value = Application.Transpose(dic.keys)
  Range("D2").Resize(j - 1, 1).Value = c()
End Sub

jbesclapez · Dec 24, 2019

Hello

DanteAmor said:
I thought that with my examples in post#5 you could put examples of real structure of your sheets.

With the images you put I will have to assume that Data1 is in column A, Data2 in column B and the results you want in columns C and D, all on the same sheet.

If the above is correct. The correct result would be:

Book1
A B C D
1 DATA1 DATA2 In Data1 not in Data2 In Data2 not in Data1
2 CAT1 Cat1 FISH2 Fish1
3 FISH2 Fish1 Lion4 Lion5
4 Bird3 Bird3 Tiger5
5 Lion4 Lion5
6 Tiger5
Sheet1a

Try this:

VBA Code:

Sub compair_columns() Dim a() As Variant, b() As Variant, c() As Variant, dic As Object, i As Long, j As Long Set dic = CreateObject("Scripting.Dictionary") dic.CompareMode = vbTextCompare a = Range("A2:A" & Range("A" & Rows.count).End(xlUp).Row).Value2 b = Range("B2:B" & Range("B" & Rows.count).End(xlUp).Row).Value2 ReDim c(1 To UBound(b), 1 To 1) j = 1 For i = 1 To UBound(a, 1) dic(a(i, 1)) = Empty Next For i = 1 To UBound(b, 1) If dic.exists(b(i, 1)) Then dic.Remove b(i, 1) Else c(j, 1) = b(i, 1): j = j + 1 Next Range("C2").Resize(dic.count, 1).Value = Application.Transpose(dic.keys) Range("D2").Resize(j - 1, 1).Value = c() End Sub

Hello DanteAmor,
I just tried your code and it is beautiful. It is soooo fast. Unbelievable. To be honest with you I did not understand it as it is too codish for me

I also tried to tweak it but did not really succeed, so I simply change the order of my columns. I will try to spend more time understanding the code later.
Thanks a lot for your efforts, your time and your patience.
I wish you a great christmas time and hope to meet again on this forum

Thanks again.

DanteAmor · Dec 24, 2019

It's nice to help you.

Thanks for the feedback and I also wish you a merry Christmas.

Improve VBA to compair columns and show difference in another sheet

jbesclapez

Active Member

Excel Facts

DanteAmor

Well-known Member

jbesclapez

Active Member

DanteAmor

Well-known Member

DanteAmor

Well-known Member

jbesclapez

Active Member

DanteAmor

Well-known Member

jbesclapez

Active Member

DanteAmor

Well-known Member

Similar threads

Forum statistics

Share this page

Improve VBA to compair columns and show difference in another sheet

Active Member

Excel Facts

Well-known Member

Active Member

Well-known Member

Well-known Member

Active Member

Well-known Member

Active Member

Well-known 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