Question

我需要比较2个excel表（Sheet1（旧报告）和Sheet2（新报告））的差异。如果Sheet2与Sheet1相比有任何添加或删除，我需要打印它。

我发现此脚本可以找到差异，但这不包括工作表中的删除。你能帮忙解决这个问题吗？以下是我期望的示例。

Sheet 1中：

S.No Name Class

abc1 1st
abc2 1st
abc3 1st

Sheet 2中：

S.No Name Class

abc1 1st
abc2 2nd
abc4 1st

比较应该告诉所有这些：

“Row（3,3）”从“1st”变为“2nd”

在“sheet2”“Row4”中插入新行

“Sheet1”“Row4”在“Sheet2”中被删除

我目前的脚本：

Sub Compare2Shts()
For Each cell In Worksheets("CompareSheet#1").UsedRange
If cell.Value <> Worksheets("CompareSheet#2").Range(cell.Address) Then
cell.Interior.ColorIndex = 3
End If
Next

For Each cell In Worksheets("CompareSheet#2").UsedRange
If cell.Value <> Worksheets("CompareSheet#1").Range(cell.Address) Then
cell.Interior.ColorIndex = 3
End If
Next
End Sub


Sub CompareAnother2Shts()
For Each cell In Worksheets("CompareSheet#1").Range("A1:J50000")
If cell.Value <> Worksheets("CompareSheet#2").Range(cell.Address) Then
cell.Interior.ColorIndex = 3
End If
Next

For Each cell In Worksheets("CompareSheet#2").Range("A1:J50000")
If cell.Value <> Worksheets("CompareSheet#1").Range(cell.Address) Then
cell.Interior.ColorIndex = 3
End If
Next
End Sub


Sub FindDupes() 'assuming both sheets are in same book and book is open
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim cell1 As Range
Dim cell2 As Range
Dim str As String
    str = InputBox("Type name of first sheet")
    Set sht1 = Worksheets(str)
    str = InputBox("Type name of second sheet")
    Set sht2 = Worksheets(str)


    sht1.Range("A65536").End(xlDown).Activate
    Selection.End(xlUp).Activate
    LastRowSht1 = ActiveCell.Row

    sht2.Activate
    sht2.Range("A65536").End(xlDown).Activate
    Selection.End(xlUp).Activate
    LastRowSht2 = ActiveCell.Row

    sht1.Activate
    For rowSht1 = 1 To LastRowSht1
        If sht1.Cells(rowSht1, 1) = "" Then Exit Sub
        For rowSht2 = 1 To LastRowSht2
            If sht1.Cells(rowSht1, 1).Value = sht2.Cells(rowSht2, 1).Value Then
                sht1.Cells(rowSht1, 1).Interior.ColorIndex = 3
                sht2.Cells(rowSht2, 1).Interior.ColorIndex = 3

            End If
        Next
    Next
    sht1.Cells(1, 1).Select
End Sub

********  ********  ********  ********  ********  ********  ********  ********

Sub checkrev()

With Sheets("Sheet1")
Sh1LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh1Range = .Range("A1:A" & Sh1LastRow)
End With
With Sheets("Sheet2")
Sh2LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh2Range = .Range("A1:A" & Sh2LastRow)
End With

'compare sheet 1 with sheet 2
For Each Sh1cell In Sh1Range
Set c = Sh2Range.Find( _
what:=Sh1cell, LookIn:=xlValues)
If c Is Nothing Then
Sh1cell.Interior.ColorIndex = 3
Sh1cell.Offset(0, 1).Interior.ColorIndex = 3
Else
If Sh1cell.Offset(0, 1) <> c.Offset(0, 1) Then
Sh1cell.Interior.ColorIndex = 6
Sh1cell.Offset(0, 1).Interior.ColorIndex = 6
End If
End If
Next Sh1cell
'compare sheet 2 with sheet 1
For Each Sh2cell In Sh2Range
Set c = Sh1Range.Find( _
what:=Sh2cell, LookIn:=xlValues)
If c Is Nothing Then
Sh2cell.Interior.ColorIndex = 3
Sh2cell.Offset(0, 1).Interior.ColorIndex = 3
Else
If Sh2cell.Offset(0, 1) <> c.Offset(0, 1) Then
Sh2cell.Interior.ColorIndex = 6
Sh2cell.Offset(0, 1).Interior.ColorIndex = 6
End If
End If
Next Sh2cell

End Sub

********  ********  ********  ********  ********  ********  ********  ********

Sub TestCompareWorksheets()
    ' compare two different worksheets in the active workbook
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
    ' compare two different worksheets in two different workbooks
'    CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
        Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub



Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Creating the report..."
    Set rptWB = Workbooks.Add
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Worksheets(2).Delete
    Wend
    Application.DisplayAlerts = True
    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    For c = 1 To maxC
        Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
        For r = 1 To maxR
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = ws1.Cells(r, c).FormulaLocal
            cf2 = ws2.Cells(r, c).FormulaLocal
            On Error GoTo 0
            If cf1 <> cf2 Then
                DiffCount = DiffCount + 1
                Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
            End If
        Next r
    Next c
    Application.StatusBar = "Formatting the report..."
    With Range(Cells(1, 1), Cells(maxR, maxC))
        .Interior.ColorIndex = 19
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error Resume Next
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error GoTo 0
    End With
    Columns("A:IV").ColumnWidth = 20
    rptWB.Saved = True
    If DiffCount = 0 Then
        rptWB.Close False
    End If
    Set rptWB = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
        "Compare " & ws1.Name & " with " & ws2.Name
End Sub

********  ********  ********  ********  ********  ********  ********  ********

Sub Match()

r1 = Worksheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
r2 = Worksheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row

Set r3 = Worksheets("sheet1")
Worksheets("sheet2").Range("B2").Select
For a = 2 To r2
For i = 2 To r1
If Cells(a, "A") = r3.Cells(i, "A") Then
temp = r3.Cells(i, "B")
te = te & "," & temp
Else
End If
Next i
Cells(a, "B") = te
te = ""
Next a
End Sub


Sub Match2()
Dim myCon As String
Dim myCell As Range
Dim cell As Range
For Each cell In Sheet2.Range("A2:A10")
myCon = ""
For Each myCell In Sheet1.Range("A1:A15")
If cell = myCell Then
If myCon = "" Then
myCon = myCell.Offset(0, 1)
Else
myCon = myCon & ", " & myCell.Offset(0, 1)
End If
End If
Next myCell
cell.Offset(0, 1) = myCon
Next cell
End Sub

********  ********  ********  ********  ********  ********  ********  ********

Sub Duplicates()
ScreenUpdating = False

'get first empty row of sheet1

'find matching rows in sheet 2
With Sheets("Masterfile")
RowCount = 1
Do While .Range("A" & RowCount) <> ""
ID = Trim(.Range("A" & RowCount))
'compare - look for ID in Sheet 2
With Sheets("List")
Set c = .Columns("A").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
End With
If c Is Nothing Then
.Range("B" & RowCount) = "No"
Else
.Range("B" & RowCount) = "Yes"
End If

RowCount = RowCount + 1
Loop
End With

ScreenUpdating = True

End Sub

Answer 1

您拥有的代码看起来过于复杂。

对于非vba解决方案，请参见下文。

表1公式：

=IF(ISERROR(VLOOKUP(A2,Sheet2!$A$2:$B$4,2,0)),"Removed",IF(VLOOKUP(A2,Sheet2!$A$2:$B$4,2,0)=B2,"Same","Changed to: " &VLOOKUP(A2,Sheet2!$A$2:$B$4,2,0)))

表2公式：

=IF(ISERROR(VLOOKUP(A2,Sheet1!$A$2:$B$4,2,0)),"Added",IF(VLOOKUP(A2,Sheet1!$A$2:$B$4,2,0)=B2,"Same","Changed"))

我意识到我可能已经简化了一些事情，但你可以调整措辞和所需的一切。您还可以根据需要应用条件格式。

比较2个Excel表格的差异

1 个答案: