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

Question

我的某些vba代码有问题。 我正在尝试比较两个报告。 如果有差异，它将在sheet2上突出显示该单元红色（如果为负）和绿色（如果其为正）。 在差异报告（第3页）上，它也会显示差异值及其受尊重的颜色。 Sheet2-Sheet1将是在sheet3上显示的差异。

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

我已经完全完成了此任务，只是我只有在数据和报表与单元格匹配时才能执行该任务。 我需要它有能力实现数据是否在sheet1的单元格A15中开始，并且如果sheet2的数据将从A17开始，我需要它知道不是从sheet2的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

Answer 1

一个简单的函数，可获取两个工作表唯一的两个范围。

VBA代码

此函数包含两个for循环，它循环遍历每张纸上的每一行并比较值。 在工作表1和工作表2中被视为“唯一”的值将分别分配给outRng1和outRng2 ，您将将它们作为参数传递（通过引用）。 它一直循环到两个列表的最后一行，这有其局限性，因此您可能需要定义要查看的最后一行。

' 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

用法

快速测试一下。 我在一个工作表上有两个列表，从A到I并更改了一些单元格。 这两个列表如下：

该测试的代码如下。 它声明两个要传递的范围。 调用函数后，这些范围将包含两个列表之间唯一的行。 它两次通过ActiveSheet ，因为两个列表都在同一张纸上。 6和7是列号。 行号是13 。 调用该函数后，它将B1和B2设置为唯一的范围地址。

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

限制

唯一的限制是它检查列表二中的每个单元格，如果它带有误报，则可能要限制此范围。