比较两张excel表格的差异
我需要比较两张excel表（表1（旧报告）和表2（新报告））的差异。如果第2页与第1页相比有任何增加或删除，我需要打印 我找到这个脚本是为了找出差异，但这不包括工作表中的删除。你能帮我修一下吗？下面是我期望的示例 第1页：比较两张excel表格的差异,excel,vba,Excel,Vba,我需要比较两张excel表（表1（旧报告）和表2（新报告））的差异。如果第2页与第1页相比有任何增加或删除，我需要打印 我找到这个脚本是为了找出差异，但这不包括工作表中的删除。你能帮我修一下吗？下面是我期望的示例 第1页： Sub Compare2Shts() For Each cell In Worksheets("CompareSheet#1").UsedRange If cell.Value <> Worksheets("CompareSheet#2").Range(cell.
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
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
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
脚本当前我有：
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
子比较2shts（）
对于工作表中的每个单元格（“比较表1”）。使用
如果cell.Value工作表（“CompareSheet#2”）.范围（cell.Address），则
cell.Interior.ColorIndex=3
如果结束
下一个
对于工作表中的每个单元格（“比较表2”）。使用
如果cell.Value工作表（“CompareSheet#1”）.范围（cell.Address），则
cell.Interior.ColorIndex=3
如果结束
下一个
端接头
子比较其他2SHTS（）
对于工作表中的每个单元格（“比较表1”）。范围（“A1:J50000”）
如果cell.Value工作表（“CompareSheet#2”）.范围（cell.Address），则
cell.Interior.ColorIndex=3
如果结束
下一个
对于工作表中的每个单元格（“比较表2”）。范围（“A1:J50000”）
如果cell.Value工作表（“CompareSheet#1”）.范围（cell.Address），则
cell.Interior.ColorIndex=3
如果结束
下一个
端接头
Sub FindDupes（）'假设两张图纸在同一本书中，并且书是打开的
Dim sht1作为工作表
将sht2变暗为工作表
变暗单元格1 As范围
暗淡的单元格2 As范围
作为字符串的Dim str
str=输入框（“第一页的类型名称”）
设置sht1=工作表（str）
str=输入框（“第二张图纸的类型名称”）
设置sht2=工作表（str）
sht1.范围（“A65536”）.结束（xlDown）.激活
选择。结束（xlUp）。激活
LastRowSht1=ActiveCell.Row
sht2.激活
sht2.范围（“A65536”）.结束（xlDown）.激活
选择。结束（xlUp）。激活
LastRowSht2=ActiveCell.Row
sht1.激活
对于rowSht1=1到LastRowSht1
如果sht1.Cells（rowSht1，1）=“”，则退出Sub
对于rowSht2=1到LastRowSht2
如果sht1.Cells（rowSht1，1）.Value=sht2.Cells（rowSht2，1）.Value，则
sht1.Cells（rowSht1，1）.Interior.ColorIndex=3
sht2.Cells（rowSht2，1）.Interior.ColorIndex=3
如果结束
下一个
下一个
sht1.单元格（1，1）。选择
端接头
******** ******** ******** ******** ******** ******** ******** ********
子检查版本（）
附页（“第1页”）
Sh1LastRow=.Cells（Rows.Count，“A”）.End（xlUp）.Row
设置Sh1Range=.Range（“A1:A”和Sh1LastRow）
以
附页（“第2页”）
Sh2LastRow=.Cells（Rows.Count，“A”）.End（xlUp）.Row
设置Sh2Range=.Range（“A1:A”和Sh2LastRow）
以
'比较表1和表2
对于SH1范围内的每个SH1单元
设置c=Sh2Range.Find（_
内容：=Sh1cell，LookIn:=xlValues）
如果c什么都不是
Sh1cell.Interior.ColorIndex=3
Sh1cell.Offset（0,1）.Interior.ColorIndex=3
其他的
如果SH1单元偏移量（0，1）c偏移量（0，1），则
Sh1cell.Interior.ColorIndex=6
Sh1cell.Offset（0,1）.Interior.ColorIndex=6
如果结束
如果结束
下一个Sh1cell
'比较表2和表1
对于SH2范围内的每个SH2单元
设置c=Sh1Range.Find（_
内容：=Sh2cell，LookIn:=xlValues）
如果c什么都不是
Sh2cell.Interior.ColorIndex=3
Sh2cell.Offset（0,1）.Interior.ColorIndex=3
其他的
如果Sh2cell.Offset（0,1）c.Offset（0,1），则
Sh2cell.Interior.ColorIndex=6
Sh2cell.Offset（0,1）.Interior.ColorIndex=6
如果结束
如果结束
下一个Sh2cell
端接头
******** ******** ******** ******** ******** ******** ******** ********
子测试比较工作表（）
'比较活动工作簿中的两个不同工作表
比较工作表工作表（“表1”）、工作表（“表2”）
'比较两个不同工作簿中的两个不同工作表
'CompareWorksheets ActiveWorkbook.Worksheets（“Sheet1”）_
工作手册（“WorkBookName.xls”）。工作表（“表2”）
端接头
子比较工作表（ws1作为工作表，ws2作为工作表）
Dim r为长，c为整数
尺寸lr1为长，lr2为长，lc1为整数，lc2为整数
Dim maxR为长，maxC为整数，cf1为字符串，cf2为字符串
将rptWB作为工作簿进行Dim，将DiffCount设置为Long
Application.ScreenUpdating=False
Application.StatusBar=“正在创建报告…”
设置rptWB=工作簿。添加
Application.DisplayAlerts=False
而工作表。计数>1
工作表（2）.删除
温德
Application.DisplayAlerts=True
使用ws1.UsedRange
lr1=.Rows.Count
lc1=.Columns.Count
以
使用ws2.UsedRange
lr2=.Rows.Count
lc2=.Columns.Count
以
maxR=lr1
maxC=lc1
如果maxR