如何比較兩個工作表並生成差異報告作為第三個工作表？

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

限制

唯一的限制是它檢查列表二中的每個單元格，如果它帶有誤報，則可能要限制此范圍。