2枚の差異を比較する

Question

差異については、2枚のシートを比較する必要があります（Sheet1（旧レポート）& Sheet2（新レポート））。 Sheet1に比べてSheet2に追加や削除がある場合は、印刷する必要があります。

このスクリプトでは違いを見つけることができましたが、これはシート内の削除を含んでいません。これを修正する手助けができますか？以下は、私が期待しているサンプルの例です。

シート1：

S.No名クラス

1. ABC1の第一

2. ABC2の第一

3. ABC3の第一

のSheet2：

S.No名クラス

1. ABC1の第一

2. ABC2第二

3. abc4の第一

。

比較は、すべてのこれらの教えてください：

"行（3,3）は"

"から "2" "シート2"" ROW4に挿入

新しい行 "1" に変更されます

"シート1" "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")) 

は私が単純化されたものを少しhavedも実現していますが、調整することができます言い回しと必要なことは何でも。必要に応じて条件付き書式を適用することもできます。