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

我的一些vba代码有问题。我试图让两份报告相互比较。如果有差异，则在表2上突出显示红色单元格（如果为负数），绿色单元格（如果为正数）。在差异报告（表3）上，它将显示差异值及其相应的颜色。第2页-第1页与第3页所示的不同

如果没有差异，则数值将显示0。如果没有差异，文本和日期将保持不变

我已经完整地完成了这项任务，但只有当数据和报告与单元格匹配时，我才能完成它。我需要它能够实现数据是否从表1的单元格A15开始，如果表2的数据将从A17开始，我需要它知道不是从表2的A15开始，而是从A17开始比较。因此，表1上的A15会将其自身与表2上的A17进行比较，以此类推整个报告

当我现在运行它时，如果报告不匹配，它会破坏它或感觉到一切都不同。我需要它有一个聪明的感觉，我猜，并知道它需要比较正确的数据，即使细胞不匹配。我已经做了大量的研究，不知道我是否必须使用vlookup、match、index或什么？如果是这样，我甚至不知道从哪里开始。代码将在下面

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

选项显式
'这是程序按顺序调用所有子过程的地方。
子运行比较计划（）
Application.ScreenUpdating=False
Sheet3创建“Sheet1”、“Sheet2”、“Sheet3”
复制范围为“第1张”、“第2张”、“第3张”
比较表“表1”、“表2”、“表3”
数据推送“Sheet1”、“Sheet2”、“Sheet3”
单元格格式“表1”、“表2”、“表3”
自动安装“Sheet1”、“Sheet2”、“Sheet3”
Application.ScreenUpdating=True
端接头
子比较表（shtSheet1作为字符串，shtSheet2作为字符串，shtSheet3作为字符串）
暗淡的迈塞尔山脉
Dim MyDiff作为整数
'对于sheet2中的每个单元格，如果在Sheet1中较少，则将其涂成红色，如果较多，则将其涂成绿色。如果两者都不正确，则不添加内饰颜色。
对于ActiveWorkbook.Worksheets（shtSheet2.UsedRange）中的每个mycell
如果不是IsDate（mycell.Value）或不是IsNumeric（mycell.Value），则
如果mycell.Value活动工作簿.Worksheets（shtSheet1）.Cells（mycell.Row，mycell.Column）.Value则
mycell.Interior.ColorIndex=33
MyDiff=MyDiff+1
其他的
mycell.Interior.ColorIndex=0
如果结束
如果结束
下一个
对于ActiveWorkbook.Worksheets（shtSheet2.UsedRange）中的每个mycell
如果是数字（mycell.Value），则
如果mycell.Value>ActiveWorkbook.Worksheets（shtSheet1）.Cells（mycell.Row，mycell.Column）.Value，则
mycell.Interior.Color=vbRed
MyDiff=MyDiff
ElseIf mycell.ValueActiveWorkbook.Worksheets（shtSheet1）.Cells（mycell.Row，mycell.Column）.Value然后
mycell.Interior.Color=vbRed
其他的
mycell.Interior.ColorIndex=0
如果结束
如果结束
下一个
如果表（shtSheet2）.单元格（1，1）.值表（shtSheet1）.单元格（1，1）.值，则
表（shtSheet2）。单元格（1，1）。内部。颜色=vbYellow
MyDiff=MyDiff+1
其他的
表（表2）。单元格（1，1）。内部。颜色索引=0
如果结束
如果表（shtSheet3）.单元格（1，1）.值表（shtSheet1）.单元格（1，1）.值，则
板材（shtSheet3）.单元格（1,1）.内饰.Color=vbYellow
其他的
表（shtSheet3）.单元格（1,1）.内部.ColorIndex=0
如果结束
'显示一个消息框以演示差异
MsgBox mydiff&“发现差异。如果日期单元格在表3上以黄色突出显示，则它们将以天为单位显示差异量。”vbInformation
ActiveWorkbook.Sheets（shtSheet2）。选择
端接头
子副本_范围（shtSheet1作为字符串，shtSheet2作为字符串，shtSheet3作为字符串）
'将工作表2复制到工作表3
工作表（“表2”）.UsedRange.Copy
工作表（“表3”）.UsedRange.PasteSpecial
端接头
子数据推送（shtSheet1作为字符串，shtSheet2作为字符串，shtSheet3作为字符串）
暗淡的迈塞尔山脉
Dim MyDiff作为整数
作为字符串的Dim cellLoc
'对于表3中与表2不同的每个单元格，将其涂成红色
对于ActiveWorkbook.Worksheets（shtSheet3.UsedRange）中的每个mycell
如果不是IsDate（mycell.Value）或不是IsNumeric（mycell.Value），则
如果mycell.Value活动工作簿.Worksheets（shtSheet1）.Cells（mycell.Row，mycell.Column）.Value则
mycell.Interior.ColorIndex=33
MyDiff=MyDiff+1
其他的
mycell.Interior.ColorIndex=0
如果结束
如果结束
下一个
对于ActiveWorkbook.Worksheets（shtSheet3.UsedRange）中的每个mycell
如果是数字（mycell.Value），则
如果mycell.Value>ActiveWorkbook.Worksheets（shtSheet1）.Cells（mycell.Row，mycell.Column）.Value，则
mycell.Interior.Color=vbRed
MyDiff=MyDiff
ElseIf mycell.ValueActiveWorkbook.Worksheets（shtSheet1）.Cells（mycell.Row，mycell.Column）.Value然后
mycell.Interior.Color=vbRed
其他的
mycell.Interior.ColorIndex=0
如果结束
如果结束
下一个
'这将显示每个单元格之间的差异，并显示一个数字
' 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

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