我遇到了一些我的vba代碼問題。我試圖讓兩份報告比較自己。如果有差異，它將突出顯示該單元格爲紅色，如果其爲負值，則在綠色的單元格上顯示爲正值。在差異報告（表單3）上，它將顯示與其尊重顏色的差異值。 Sheet2 - Sheet1將顯示在sheet3上。如何比較兩個工作表並生成差異報告作爲第三個工作表？

如果沒有差別，它將顯示數字值爲0。如果沒有區別，文本和日期將保持不變。

我已經完整地完成了這項任務，除非我只有在數據和報告與單元匹配的情況下才能工作。我需要它能夠實現數據是否從sheet1的單元格A15開始，並且如果sheet2的數據從A17開始，我需要知道它不是從sheet2的A15開始，而是開始在A17進行比較。因此，sheet1上的A15將自己與sheet2上的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

來源

2015-09-09 BuckeyeRJB

一個簡單的函數來獲得兩個工作表唯一的兩個範圍。

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

限制

唯一的限制是它會檢查列表中有兩個的每一個細胞，你可能想在它與誤報情況下限制這一點。

來源

2015-12-31 13:35:33

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

回答

VBA代碼

使用

限制

相關問題