如何比较两个工作表并生成差异报告作为第三个工作表？

Question

I am having an issue with some of my vba code. I am trying to have two reports compare themselves. If there are differences it will highlight that cell red if its negative and green if its positive on sheet2. On the difference report (sheet3) it will show the difference value with its respected color as well. Sheet2 - Sheet1 would be the difference shown on sheet3.

If there is no difference it will display 0 for numeric values. Text and dates will stay the same if there is no difference.

I have completed this task in full except I only have it to where it will work if the data and reports match up with cells. I need it to have the capability to realize if the data starts in cell A15 on sheet1, and if sheet2's data would start at A17, I need it to know to not start at A15 on sheet2 but to start the comparison at A17. So A15 on sheet1 would compare itself to A17 on sheet2 and so on and so forth for the entire report.

When I run this now it would break it or sense everything is different if the reports don't match up. I need it to have a smart sense I guess and know that it needs to compare the correct data even if the cells don't match up. I have done tons of research and don't know if I have to use vlookup, match, index, or what? If so I don't even know where to begin. Code will be below.

Option Explicit
'This is where the program calls all sub procedures In Order.
Sub RunCompareSchedules()
Application.ScreenUpdating = False
Sheet3Creation "Sheet1", "Sheet2", "Sheet3"
Copy_range "Sheet1", "Sheet2", "Sheet3"
compareSheets "Sheet1", "Sheet2", "Sheet3"
DataPush "Sheet1", "Sheet2", "Sheet3"
CellFormat "Sheet1", "Sheet2", "Sheet3"
AutoFit "Sheet1", "Sheet2", "Sheet3"
Application.ScreenUpdating = True
End Sub


Sub compareSheets(shtSheet1 As String, shtSheet2 As String, shtSheet3 As String)

Dim mycell As Range
Dim mydiffs As Integer


'For each cell in sheet2 that is less in Sheet1, color it red, if it's more color it Green.  If neither of these are true that don't add interior color.
 For Each mycell In ActiveWorkbook.Worksheets(shtSheet2).UsedRange
 If Not IsDate(mycell.Value) Or Not IsNumeric(mycell.Value) Then
 If mycell.Value <> ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.ColorIndex = 33
    mydiffs = mydiffs + 1
 Else
    mycell.Interior.ColorIndex = 0
 End If
 End If
 Next


 For Each mycell In ActiveWorkbook.Worksheets(shtSheet2).UsedRange
 If IsNumeric(mycell.Value) Then
 If mycell.Value > ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbRed
    mydiffs = mydiffs
 ElseIf mycell.Value < ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbGreen
 Else
    mycell.Interior.ColorIndex = 0
 End If
 End If
 Next


 'For each cell in the date colomn sheet2 that is not the same in Sheet1, color it yellow
 For Each mycell In ActiveWorkbook.Worksheets(shtSheet2).UsedRange
 If IsDate(mycell.Value) Then
 If mycell.Value < ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbGreen
    mydiffs = mydiffs
 ElseIf mycell.Value > ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbRed
 Else
    mycell.Interior.ColorIndex = 0
 End If
 End If
 Next

If Sheets(shtSheet2).Cells(1, 1).Value <> Sheets(shtSheet1).Cells(1, 1).Value Then
Sheets(shtSheet2).Cells(1, 1).Interior.Color = vbYellow
mydiffs = mydiffs + 1
Else
Sheets(shtSheet2).Cells(1, 1).Interior.ColorIndex = 0
End If



If Sheets(shtSheet3).Cells(1, 1).Value <> Sheets(shtSheet1).Cells(1, 1).Value Then
Sheets(shtSheet3).Cells(1, 1).Interior.Color = vbYellow
Else
Sheets(shtSheet3).Cells(1, 1).Interior.ColorIndex = 0
End If


'Display a message box to demonstrate the differences
MsgBox mydiffs & " differences found.  If Date cells are highlighted yellow on Sheet3, they will show the amount of difference in days.", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select

End Sub
Sub Copy_range(shtSheet1 As String, shtSheet2 As String, shtSheet3 As String)

 'Copy worksheet 2 to worksheet 3
 Worksheets("Sheet2").UsedRange.Copy
 Worksheets("Sheet3").UsedRange.PasteSpecial

 End Sub

 Sub DataPush(shtSheet1 As String, shtSheet2 As String, shtSheet3 As String)

 Dim mycell As Range
 Dim mydiffs As Integer
 Dim cellLoc As String


 'For each cell in sheet3 that is not the same in Sheet2, color it red
 For Each mycell In ActiveWorkbook.Worksheets(shtSheet3).UsedRange
 If Not IsDate(mycell.Value) Or Not IsNumeric(mycell.Value) Then
 If mycell.Value <> ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.ColorIndex = 33
    mydiffs = mydiffs + 1
 Else
    mycell.Interior.ColorIndex = 0
 End If
 End If
 Next


 For Each mycell In ActiveWorkbook.Worksheets(shtSheet3).UsedRange
 If IsNumeric(mycell.Value) Then
 If mycell.Value > ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbRed
    mydiffs = mydiffs
 ElseIf mycell.Value < ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbGreen
 Else
    mycell.Interior.ColorIndex = 0
 End If
 End If
 Next


 'For each cell in the date colomn sheet3 that is not the same in Sheet2, color it yellow
 For Each mycell In ActiveWorkbook.Worksheets(shtSheet3).UsedRange
 If IsDate(mycell.Value) Then
 If mycell.Value < ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbGreen
 ElseIf mycell.Value > ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    mycell.Interior.Color = vbRed
 Else
    mycell.Interior.ColorIndex = 0
 End If
 End If
  Next


 'This will show the difference between each cell with a numeric value from sheet1 and 2, in sheet3.  If it's not different, it will show a zero.
 For Each mycell In Sheets(shtSheet3).UsedRange
 If IsNumeric(mycell.Value) Then
 If Not mycell.Value = Sheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    ActiveWorkbook.Worksheets(shtSheet3).Cells(mycell.Row, mycell.Column).Value = _
    ActiveWorkbook.Worksheets(shtSheet2).Cells(mycell.Row, mycell.Column).Value - ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value
  ElseIf mycell.Value = "" Then
    ActiveWorkbook.Worksheets(shtSheet3).Cells(mycell.Row, mycell.Column).Value = ""
  Else
    ActiveWorkbook.Worksheets(shtSheet3).Cells(mycell.Row, mycell.Column).Value = 0
  End If
  End If
  Next

  End Sub

 Public Sub CellFormat(shtSheet1 As String, shtSheet2 As String, shtSheet3 As String)


 Dim mycell As Range

 'This will show the difference of dates, in days, from sheet1 and 2, in sheet3.  If it's not different it will still show the date.
 For Each mycell In Sheets(shtSheet3).UsedRange
 If IsDate(mycell.Value) Then
 If Not mycell.Value = Sheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    ActiveWorkbook.Worksheets(shtSheet3).Cells(mycell.Row, mycell.Column).Value = _
    ActiveWorkbook.Worksheets(shtSheet2).Cells(mycell.Row, mycell.Column).Value - ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value
 End If
 End If
 Next


 'This will format the cells in the date column to be in the General format if the cell is yellow.
  For Each mycell In Sheets(shtSheet3).UsedRange
  If IsDate(mycell.Value) Then
  If mycell.Value <> ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    ActiveWorkbook.Worksheets(shtSheet3).Cells(mycell.Row, mycell.Column).NumberFormat = "#,##0"
  ElseIf mycell.Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
    ActiveWorkbook.Worksheets(shtSheet3).Cells(mycell.Row, mycell.Column).NumberFormat = "m/d/yyyy"
  End If
  End If
  Next
  End Sub

  Sub Sheet3Creation(shtSheet1 As String, shtSheet2 As String, shtSheet3 As String)


  Dim shName As String, Wsh As Worksheet
  shName = "Sheet3"


 'This will loop through existing sheets to see if there is a sheet named "Sheet3". If there is a "Sheet3", then a message box will appear to
 'let the user know that "Sheet3" already exists.  If not it will exit loop and go to next area where it will create "Sheet3" at the end of
 'excel sheets 1 and 2.
 For Each Wsh In Sheets
 If Wsh.Name = shName Then
 If MsgBox("" & shName & " already exists! Please press Yes to continue or No to cancel operation.", vbYesNo) = vbNo Then
 End
 End If
 Exit Sub  'Exit sub will allow the entire sub procedure to end if the "For If" Loop is true.  If it's not true it will continue on.
 End If
  Next

'This section will create a worksheet called "Sheet3" if the "For If" loop above is false.
Set Wsh = ThisWorkbook.Sheets.Add(After:= _
      ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      Wsh.Name = shName

 End Sub

 Sub AutoFit(shtSheet1 As String, shtSheet2 As String, shtSheet3 As String)

 ActiveWorkbook.Worksheets(shtSheet1).UsedRange.Columns.AutoFit
 ActiveWorkbook.Worksheets(shtSheet2).UsedRange.Columns.AutoFit
 ActiveWorkbook.Worksheets(shtSheet3).UsedRange.Columns.AutoFit

 End Sub

Answer 1

A simple function to get two ranges that are unique to two sheets.

VBA Code

This function contains two for-loops, it loops through each row on each sheet and compares the values. The values that are considered 'Unique' in sheet 1 anbd sheet 2 will be assigned to outRng1 and outRng2 , respectively, which you will pass as arguments (by reference). It loops until the last row on the two lists, this has it's limitations so you may want to define the last row to look at.

' Find the rows that are unique between two lists
'   ws1     : First worksheet to look at
'   ws2     : Second worksheet to look at
'   col1    : The column in the first worksheet to compare values
'   col2    : The column in the second worksheet to compare values
'   row1    : Row to look at on sheet 1
'   row2    : Row to look at on sheet 2
'   outRng1 : Returns Range argument that's unique to sheet 1
'   outRng2 : Returns Range argument that's unique to sheet 2
'   Returns : if a unique Range has been found
Public Function GetUniqueRanges( _
    ws1 As Worksheet, _
    ws2 As Worksheet, _
    col1 As Long, _
    col2 As Long, _
    row1 As Long, _
    row2 As Long, _
    ByRef outRng1 As Range, _
    ByRef outRng2 As Range _
    ) As Boolean

    Dim tRow1 As Long, tRow2 As Long, endRow1 As Long, endRow2 As Long  ' Create Temp vars
    endRow1 = ws1.Cells(1048576, col1).End(xlUp).Row                    ' Get last row in sheet 1
    endRow2 = ws2.Cells(1048576, col2).End(xlUp).Row                    ' Get last row in sheet 2

    GetUniqueRanges = False

    For tRow1 = row1 To endRow1
        For tRow2 = row2 To endRow2
            If ws1.Cells(tRow1, col1) = ws2.Cells(tRow2, col2) Then
                GetUniqueRanges = True
                Set outRng1 = ws1.Range(tRow1 & ":" & row1)
                Set outRng2 = ws2.Range(tRow2 & ":" & row2)
                Exit Function
            End If
        Next
    Next

End Function

Usage

Here's a quick to test. I had two lists on one Worksheet that goes from A to I and changed some cells. The two lists are as follows:

The code for the test is below. It declares two ranges to pass. After calling the function these ranges will contain the rows that are unique between the two lists. It passes the ActiveSheet twice, as both lists are on the same sheet. 6 and 7 is the column numbers. 13 are the row numbers. After calling the function it sets B1 and B2 to the unique range addresses.

Public Sub test()
    Dim UniqRng1 As Range, UniqRng2 As Range
    If GetUniqueRanges(ActiveSheet, ActiveSheet, 6, 7, 13, 13, UniqRng1, UniqRng2) = True Then
        Range("B1") = UniqRng1.Address
        Range("B2") = UniqRng2.Address            
    End If
End Sub

Limitations

The only limitation is it checks every cell in list two, you may want to limit this in case it comes with false positives.