我遇到了一些我的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代码

使用

限制

相关问题