VBA to Compare 2 sheets and count and color color similarities

jskasango

jskasango

Board Regular
Joined
Jul 18, 2012
Messages
202
Office Version
  1. 365
Platform
  1. Windows
Hi ALL, I have an assignment to compare all of Sheet1 contents with Sheet2 contents (more than 30,000 rows) then count and color similarities in Sheet1.
Both sheets have a header row and I want the counts to be inserted at row2 of each column in sheet1 when the search ends.
Some contents in sheet1 appear more than once and each find should be treated as a new find.
Please help with a VBA code that I can use.
TIA
K
 
Sort by date Sort by votes
Since the Master workbook has basically static list, then the macro can be in that workbook. Once macro is run, you can select Candidate workbook (which can be any name as I understood). I presumed the Candidate workbook will not have either Found nor NotFoumd initially. Is this correct?
 
Upvote 0

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Zot said:
Since the Master workbook has basically static list, then the macro can be in that workbook. Once macro is run, you can select Candidate workbook (which can be any name as I understood). I presumed the Candidate workbook will not have either Found nor NotFoumd initially. Is this correct?
Click to expand...
You are very correct!
 
Upvote 0
This code will be in workbook Master. Once run, it will ask for Candidate file which contains a sheets called Candidates. Then sheets Found and NotFound will be created. At the end of execution, the workbook Candidates will be saved.

Workbook Master will have a sheet called Master
Workbook Candidates will have a sheet called Candidates

VBA Code: 
Sub Segregate()

Dim n As Long
Dim FName As Variant
Dim cell As Range, rngData As Range, rngMaster As Range
Dim dictData As Object
Dim wbMaster As Workbook, wbCand As Workbook
Dim wsMaster As Worksheet, wsCand As Worksheet, wsFound As Worksheet, wsNotFound As Worksheet

Application.ScreenUpdating = False

Set wbMaster = ActiveWorkbook
Set wsMaster = wbMaster.Sheets("Master")

' This will let you select the Candidate workbook to work on
FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", Title:="Select a File")
If FName = False Then Exit Sub                         'CANCEL is clicked
' Define opened Workbook as wbCand while opening it.
Set wbCand = Workbooks.Open(Filename:=FName, UpdateLinks:=False)
Set wsCand = wbCand.Sheets("Candidates")

Set wsFound = wbCand.Sheets.Add(After:=wsCand)
ActiveSheet.Name = "Found"
Set wsNotFound = wbCand.Sheets.Add(After:=wsFound)
ActiveSheet.Name = "NotFound"

Set dictData = CreateObject("Scripting.Dictionary")
Set rngData = wsCand.Range("A1", wsCand.Cells(Rows.Count, "A").End(xlUp))
Set rngMaster = wsMaster.Range("A2", wsMaster.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngMaster
    If Not dictData.Exists(cell.Value) Then dictData.Add cell.Value, Nothing
Next
    
For Each cell In rngData
    If dictData.Exists(cell.Value) Then
        n = wsFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsFound.Range("A" & n)
    Else
        n = wsNotFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsNotFound.Range("A" & n)
    End If
Next

Application.DisplayAlerts = False
wbCand.Save
Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub
 
Upvote 0
Zot said:
This code will be in workbook Master. Once run, it will ask for Candidate file which contains a sheets called Candidates. Then sheets Found and NotFound will be created. At the end of execution, the workbook Candidates will be saved.

Workbook Master will have a sheet called Master
Workbook Candidates will have a sheet called Candidates

VBA Code: 
Sub Segregate()

Dim n As Long
Dim FName As Variant
Dim cell As Range, rngData As Range, rngMaster As Range
Dim dictData As Object
Dim wbMaster As Workbook, wbCand As Workbook
Dim wsMaster As Worksheet, wsCand As Worksheet, wsFound As Worksheet, wsNotFound As Worksheet

Application.ScreenUpdating = False

Set wbMaster = ActiveWorkbook
Set wsMaster = wbMaster.Sheets("Master")

' This will let you select the Candidate workbook to work on
FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", Title:="Select a File")
If FName = False Then Exit Sub                         'CANCEL is clicked
' Define opened Workbook as wbCand while opening it.
Set wbCand = Workbooks.Open(Filename:=FName, UpdateLinks:=False)
Set wsCand = wbCand.Sheets("Candidates")

Set wsFound = wbCand.Sheets.Add(After:=wsCand)
ActiveSheet.Name = "Found"
Set wsNotFound = wbCand.Sheets.Add(After:=wsFound)
ActiveSheet.Name = "NotFound"

Set dictData = CreateObject("Scripting.Dictionary")
Set rngData = wsCand.Range("A1", wsCand.Cells(Rows.Count, "A").End(xlUp))
Set rngMaster = wsMaster.Range("A2", wsMaster.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngMaster
    If Not dictData.Exists(cell.Value) Then dictData.Add cell.Value, Nothing
Next
   
For Each cell In rngData
    If dictData.Exists(cell.Value) Then
        n = wsFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsFound.Range("A" & n)
    Else
        n = wsNotFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsNotFound.Range("A" & n)
    End If
Next

Application.DisplayAlerts = False
wbCand.Save
Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub
Click to expand...
PERFECT! Let me give it a spin in a few minutes.
 
Upvote 0
jskasango said:
What line should I add to make the code overwrite the "Found" and "NotFound" Sheets if I re-run on the same list more than once?
Click to expand...
It would be easier to just delete those sheet and re-create again I suppose.
VBA Code: 
Sub Segregate()

Dim n As Long
Dim FName As Variant
Dim cell As Range, rngData As Range, rngMaster As Range
Dim dictData As Object
Dim wbMaster As Workbook, wbCand As Workbook
Dim ws As Worksheet, wsMaster As Worksheet, wsCand As Worksheet, wsFound As Worksheet, wsNotFound As Worksheet

Application.ScreenUpdating = False

Set wbMaster = ActiveWorkbook
Set wsMaster = wbMaster.Sheets("Master")

' This will let you select the Candidate workbook to work on
FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", Title:="Select a File")
If FName = False Then Exit Sub                         'CANCEL is clicked
' Define opened Workbook as wbCand while opening it.
Set wbCand = Workbooks.Open(Filename:=FName, UpdateLinks:=False)
Set wsCand = wbCand.Sheets("Candidates")

' Delete existing Found and NotFound sheetss if found
For Each ws In wbCand.Sheets
    Select Case ws.Name
        Case "Found", "NotFound"
            ws.Delete
    End Select
Next

Set wsFound = wbCand.Sheets.Add(After:=wsCand)
ActiveSheet.Name = "Found"
Set wsNotFound = wbCand.Sheets.Add(After:=wsFound)
ActiveSheet.Name = "NotFound"

Set dictData = CreateObject("Scripting.Dictionary")
Set rngData = wsCand.Range("A1", wsCand.Cells(Rows.Count, "A").End(xlUp))
Set rngMaster = wsMaster.Range("A2", wsMaster.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngMaster
    If Not dictData.Exists(cell.Value) Then dictData.Add cell.Value, Nothing
Next
    
For Each cell In rngData
    If dictData.Exists(cell.Value) Then
        n = wsFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsFound.Range("A" & n)
    Else
        n = wsNotFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsNotFound.Range("A" & n)
    End If
Next

Application.DisplayAlerts = False
wbCand.Save
Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub
 
Upvote 0
Solution
Zot said:
It would be easier to just delete those sheet and re-create again I suppose.
VBA Code: 
Sub Segregate()

Dim n As Long
Dim FName As Variant
Dim cell As Range, rngData As Range, rngMaster As Range
Dim dictData As Object
Dim wbMaster As Workbook, wbCand As Workbook
Dim ws As Worksheet, wsMaster As Worksheet, wsCand As Worksheet, wsFound As Worksheet, wsNotFound As Worksheet

Application.ScreenUpdating = False

Set wbMaster = ActiveWorkbook
Set wsMaster = wbMaster.Sheets("Master")

' This will let you select the Candidate workbook to work on
FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", Title:="Select a File")
If FName = False Then Exit Sub                         'CANCEL is clicked
' Define opened Workbook as wbCand while opening it.
Set wbCand = Workbooks.Open(Filename:=FName, UpdateLinks:=False)
Set wsCand = wbCand.Sheets("Candidates")

' Delete existing Found and NotFound sheetss if found
For Each ws In wbCand.Sheets
    Select Case ws.Name
        Case "Found", "NotFound"
            ws.Delete
    End Select
Next

Set wsFound = wbCand.Sheets.Add(After:=wsCand)
ActiveSheet.Name = "Found"
Set wsNotFound = wbCand.Sheets.Add(After:=wsFound)
ActiveSheet.Name = "NotFound"

Set dictData = CreateObject("Scripting.Dictionary")
Set rngData = wsCand.Range("A1", wsCand.Cells(Rows.Count, "A").End(xlUp))
Set rngMaster = wsMaster.Range("A2", wsMaster.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngMaster
    If Not dictData.Exists(cell.Value) Then dictData.Add cell.Value, Nothing
Next
   
For Each cell In rngData
    If dictData.Exists(cell.Value) Then
        n = wsFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsFound.Range("A" & n)
    Else
        n = wsNotFound.Range("A" & Rows.Count).End(xlUp).Row + 1
        wsCand.Range("A" & cell.Row, "D" & cell.Row).Copy wsNotFound.Range("A" & n)
    End If
Next

Application.DisplayAlerts = False
wbCand.Save
Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub
Click to expand...
I owe you! Thanks a lot!
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Formula to change font color in part of cell only
Replies
2
Views
324
Nathan Asius
N
O
  • Question
Count only one occurrence of all criteria being met
Replies
8
Views
408
KRice
K
B
  • Solved
VBA to delete certain sheets based on cell contents with IF formula
Replies
3
Views
169
Peter_SSs
Peter_SSs
Z
  • Solved
Index / Match cell color with VBA
Replies
2
Views
276
zankzank
Z
B
  • Question
Excel VBA When new rows are added to table 1 copy the information to table 2
Replies
0
Views
403
BlueHawker42
B

Forum statistics

Threads
1,214,646
Messages
6,120,717
Members
448,985
Latest member
chocbudda

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