Excel VBA - Comparison two sheets

[NeewBie]

Hi,

I have this script to compare:

'Option Explicit

'Sub FindDuplicate()


'Dim LastRow As Long
'Dim MyRg1 As Range, MyRg2 As Range
'Dim A As Range
'Dim F
' Application.ScreenUpdating = False
'LastRow = Range("a" & Rows.Count).End(xlUp).Row
'Range("B1:B" & LastRow).ClearContents
'Set MyRg1 = Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
'With Sheets("Sheet2")
'Set MyRg2 = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp))
'End With
'With MyRg2
'For Each A In MyRg1
'If (A <> Empty) Then
'Set F = .Find(What:=A.Value, After:=.Cells(1, 1), LookIn:=xlValues, _
'LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'MatchCase:=False)
'If (Not F Is Nothing) Then
'A.Offset(0, 1) = .Cells(F.Row, F.Column + 1)
'End If
'End If
'Next A
' End With
'Application.ScreenUpdating = True

'End Sub

What I cant it to do is to colorize (if its works) when it find dublicates or that the script write all dublicates in worksheet 3. I also want it so search in the whole range in sheet 1 and sheet 2. Someone that can helps me?

Thank you!

 

[HaHoBe]

Hi, NeewBie,

you could do as you like. If this line of code is commented (custom colour should be green) it will be passed by the compiler when the code is executed. For my part: I would keep the code until everything is fine.

A different approach not using Find but using Application.Match:

Sub ColorDuplicates()

  Dim lngCounter As Long
  Dim lngLR As Long
  Dim varRes As Variant
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet
  
  Const clngSTART As Long = 1
  Const cstrTAB_1 As String = "Data1"
  Const cstrTAB_2 As String = "Data2"
  Const clngCI As Long = 6
  
  On Error GoTo handle_error
  Set ws1 = Sheets(cstrTAB_1)
  ws1.Columns(1).Interior.ColorIndex = xlNone
  Set ws2 = Sheets(cstrTAB_2)
  ws2.Columns(1).Interior.ColorIndex = xlNone
  On Error GoTo 0
  
    With ws1
      lngLR = .Cells(.Rows.Count, "A").End(xlUp).Row
      For lngCounter = clngSTART To lngLR
        varRes = Application.Match(.Cells(lngCounter, 1).Value, ws2.Columns(1), 0)
        If Not IsError(varRes) Then
          .Cells(lngCounter, 1).Interior.ColorIndex = clngCI
          ws2.Cells(varRes, 1).Interior.ColorIndex = clngCI
        End If
      Next lngCounter
    End With
  
exit_here:
  Set ws2 = Nothing
  Set ws1 = Nothing
  
  Exit Sub
  
handle_error:
    MsgBox "A problem occurred with the sheet names provided. Please check the appropriate names.", _
        vbInformation, "Stop macro here"
    Resume exit_here

End Sub

Please be informed that any colour of the cells in both Columns A will be reset to none at the begininng of the procedure.

If you want to take the opposite route and colour the uniques:

Sub ColorUniques()
  Dim arrWS
  Dim lngArray As Long
  Dim lngCounter As Long
  Dim lngLR As Long
  Dim varRes As Variant
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet
  Dim wsS As Worksheet
  
  Const clngSTART As Long = 1
  Const cstrTAB_1 As String = "Data1"
  Const cstrTAB_2 As String = "Data2"
  Const clngCI As Long = 42
  
  On Error GoTo handle_error
  Set ws1 = Sheets(cstrTAB_1)
  ws1.Columns(1).Interior.ColorIndex = xlAutomatic
  Set ws2 = Sheets(cstrTAB_2)
  ws2.Columns(1).Interior.ColorIndex = xlAutomatic
  On Error GoTo 0
  
  arrWS = Array(ws1, ws2)
  
  For lngArray = LBound(arrWS) To UBound(arrWS)
    With arrWS(lngArray)
      If lngArray = 0 Then
        Set wsS = ws2
      Else
        Set wsS = ws1
      End If
      lngLR = .Cells(.Rows.Count, "A").End(xlUp).Row
      For lngCounter = clngSTART To lngLR
        If Not .Cells(lngCounter, 1).Interior.ColorIndex = clngCI Then
          varRes = Application.Match(.Cells(lngCounter, 1).Value, wsS.Columns(1), 0)
          If Not IsError(varRes) Then
            .Cells(lngCounter, 1).Interior.ColorIndex = clngCI
          End If
        End If
      Next lngCounter
    End With
  Next lngArray
  
exit_here:
  Set wsS = Nothing
  Set ws2 = Nothing
  Set ws1 = Nothing
  
  Exit Sub
  
handle_error:
    MsgBox "A problem occurred with the sheet names provided. Please check the appropriate names.", _
        vbInformation, "Stop macro here"
    Resume exit_here

End Sub

Ciao,
Holger

 

[NeewBie]

Thank you for youre answer!!! You are Einstein . I have try to do one more thing, how can I use it true my whole range and not onli in column "A"?

Thnx!

 

[HaHoBe]

Hi, NeewBie,

thanks for the compliment but I´m definitely not.

Could you be a bit more specific: search all items from Sheet1 Column A in all cells on Sheet2? Or do you really mean search all items from Sheet1 in Sheet2? This sounds a bit like comparing data lists (i.e. address data) to me.

Ciao,
Holger

 

[NeewBie]

Hi, NeewBie,

thanks for the compliment but I´m definitely not.

Could you be a bit more specific: search all items from Sheet1 Column A in all cells on Sheet2? Or do you really mean search all items from Sheet1 in Sheet2? This sounds a bit like comparing data lists (i.e. address data) to me.

Ciao,
Holger

Yes you are m8 !

Sorry for my bad english, I want it to compare the whole range (all columns and rows) in both sheets (sheet 1 and 2) and not only column ("A").

Cheers m8!

 

[HaHoBe]

Hi, NeewBie,

sorry to ask again: do you mean any cell of one column against all cells in the range of the other sheet or one cell of one column against the cells of the very same column of the other sheet?

Ciao,
Holger

 

[NeewBie]

Hi, NeewBie,

sorry to ask again: do you mean any cell of one column against all cells in the range of the other sheet or one cell of one column against the cells of the very same column of the other sheet?

Ciao,
Holger

Hi Olger!

Again, thank you for you help!!! Right now the script is only compares column A in sheet 1 and column A in sheet 2. I want it to compare the whole range (with the whole range I mean all cells and all columns in sheet 1 with sheet 2).

Cheers m8!

 

[HaHoBe]

Hi, NeewBie,

for the greater range that you mention I usually apply the Find-Method:

Sub ColorDuplicates_Find_USedRange()
  Dim blnOut As Boolean
  Dim rngFound As Range
  Dim rngCell As Range
  Dim strAddress As String
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet
  
  Const cstrTAB_1 As String = "Data1"
  Const cstrTAB_2 As String = "Data2"
  Const clngCI As Long = 6
  
  On Error GoTo handle_error
  Set ws1 = Sheets(cstrTAB_1)
  ws1.UsedRange.Interior.ColorIndex = xlNone
  Set ws2 = Sheets(cstrTAB_2)
  ws2.UsedRange.Interior.ColorIndex = xlNone
  On Error GoTo 0
  
  With ws1
    For Each rngCell In .UsedRange
      blnOut = False
      Set rngFound = ws2.UsedRange.Find( _
          What:=rngCell.Text, _
          LookIn:=xlValues, _
          LookAt:=xlWhole, _
          SearchOrder:=xlByRows)
      If Not rngFound Is Nothing Then
        strAddress = rngFound.Address
        rngCell.Interior.ColorIndex = clngCI
        rngFound.Interior.ColorIndex = clngCI
        While ActiveCell.Address <> strAddress And blnOut = False
          Set rngFound = ws2.UsedRange.FindNext(After:=rngFound)
          If rngFound.Address = strAddress Then blnOut = True
          rngCell.Interior.ColorIndex = clngCI
          rngFound.Interior.ColorIndex = clngCI
        Wend
      End If
    Next rngCell
  End With
  
exit_here:
  Set ws2 = Nothing
  Set ws1 = Nothing
  
  Exit Sub
  
handle_error:
    MsgBox "A problem occurred with the sheet names provided. Please check the appropriate names.", _
        vbInformation, "Stop macro here"
    Resume exit_here

End Sub

Ciao,
Holger

 

[NeewBie]

Hi, NeewBie,

for the greater range that you mention I usually apply the Find-Method:

Sub ColorDuplicates_Find_USedRange()
  Dim blnOut As Boolean
  Dim rngFound As Range
  Dim rngCell As Range
  Dim strAddress As String
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet
  
  Const cstrTAB_1 As String = "Data1"
  Const cstrTAB_2 As String = "Data2"
  Const clngCI As Long = 6
  
  On Error GoTo handle_error
  Set ws1 = Sheets(cstrTAB_1)
  ws1.UsedRange.Interior.ColorIndex = xlNone
  Set ws2 = Sheets(cstrTAB_2)
  ws2.UsedRange.Interior.ColorIndex = xlNone
  On Error GoTo 0
  
  With ws1
    For Each rngCell In .UsedRange
      blnOut = False
      Set rngFound = ws2.UsedRange.Find( _
          What:=rngCell.Text, _
          LookIn:=xlValues, _
          LookAt:=xlWhole, _
          SearchOrder:=xlByRows)
      If Not rngFound Is Nothing Then
        strAddress = rngFound.Address
        rngCell.Interior.ColorIndex = clngCI
        rngFound.Interior.ColorIndex = clngCI
        While ActiveCell.Address <> strAddress And blnOut = False
          Set rngFound = ws2.UsedRange.FindNext(After:=rngFound)
          If rngFound.Address = strAddress Then blnOut = True
          rngCell.Interior.ColorIndex = clngCI
          rngFound.Interior.ColorIndex = clngCI
        Wend
      End If
    Next rngCell
  End With
  
exit_here:
  Set ws2 = Nothing
  Set ws1 = Nothing
  
  Exit Sub
  
handle_error:
    MsgBox "A problem occurred with the sheet names provided. Please check the appropriate names.", _
        vbInformation, "Stop macro here"
    Resume exit_here

End Sub

Ciao,
Holger

**** my friend, you are soooooo smart! Thank you so much! It works PERFECT!!!!!!!!!!