VBA代码

Question

我的一些vba代码存在问题。我想让两个报告比较一下。如果存在差异，则如果其为负，则将突出显示该单元格为红色;在差异报告（sheet3）上，它将显示差异值及其受尊重的颜色。 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

Answer 1

一个简单的函数，可以获得两个唯一的两个范围。

VBA代码

此函数包含两个for循环，它遍历每个工作表上的每一行并比较这些值。被视为＆＃39;唯一的值＆＃39;在表1中，anbd表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

限制

唯一的限制是它会检查列表2中的每个单元格，您可能希望限制它以防它出现误报。

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

1 个答案:

VBA代码

用法

限制