Compare Excel worksheets(repost)
$5-10 USD
Veröffentlicht vor etwa 15 Jahren
$5-10 USD
Bezahlt bei Lieferung
I need a Excel macro that will compare 2 worksheets.? The results of the comparison will be displayed on a third worksheet.? I've downloaded some? vb source code that works almost to my specifications.? It should serve as a good starting point. The macro should be able to compare two worksheets with several thousand rows each.
## Deliverables
This code will compare 2 Excel worksheets and place the differences on a third worksheets.
*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
? ? ? [login to view URL] = False
? ? ? [login to view URL] = "Creating the report..."
? ? ? Set rptWB = [login to view URL]
? ? ? [login to view URL] = False
? ? ? While [login to view URL] > 1
? ? ? ? ? ? ? Worksheets(2).Delete
? ? ? Wend
? ? ? [login to view URL] = True
? ? ? With [login to view URL]
? ? ? ? ? ? ? lr1 = .[login to view URL]
? ? ? ? ? ? ? lc1 = .[login to view URL]
? ? ? End With
? ? ? With [login to view URL]
? ? ? ? ? ? ? lr2 = .[login to view URL]
? ? ? ? ? ? ? lc2 = .[login to view URL]
? ? ? 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
? ? ? ? ? ? ? [login to view URL] = "Comparing cells " & Format(c / maxC, "0 %") & "..."
? ? ? ? ? ? ? For r = 1 To maxR
? ? ? ? ? ? ? ? ? ? ? cf1 = ""
? ? ? ? ? ? ? ? ? ? ? cf2 = ""
? ? ? ? ? ? ? ? ? ? ? On Error Resume Next
? ? ? ? ? ? ? ? ? ? ? cf1 = [login to view URL](r, c).FormulaLocal
? ? ? ? ? ? ? ? ? ? ? cf2 = [login to view URL](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
? ? ? [login to view URL] = "Formatting the report..."
? ? ? With Range(Cells(1, 1), Cells(maxR, maxC))
? ? ? ? ? ? ? .[login to view URL] = 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
? ? ? [login to view URL] = True
? ? ? If DiffCount = 0 Then
? ? ? ? ? ? ? [login to view URL] False
? ? ? End If
? ? ? Set rptWB = Nothing
? ? ? [login to view URL] = False
? ? ? [login to view URL] = True
? ? ? MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
? ? ? ? ? ? ? "Compare " & [login to view URL] & " with " & [login to view URL]
End Sub*
*This example macro shows how to use the macro above:
Sub TestCompareWorksheets()
? ? ? ' compare two different worksheets in the active workbook
? ? ? CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
? ? ? ' compare two different worksheets in two different workbooks
? ? ? CompareWorksheets [login to view URL]("Sheet1"), _
? ? ? ? ? ? ? Workbooks("[login to view URL]").Worksheets("Sheet2")
End Sub*
The two worksheests that I will be using has thousands of rows of data each.? Worksheet1 will? consist of new data and Worksheet2 will be made of original data.
?
I would like the code to do the following:
INPUT:? 2 worksheets with 33 columns each.? Worksheet1 can have anywhere between 1 and several thousand rows.? Worksheet2 will normally have several thousand rows.? Focus should be on 4 specific columns: Action, bank_No, Code, and program.? 'Action' will only be populated in worksheet1 with the values add, remove, or update
1.? Sort worksheet1 by ‘Action’
2.? If [login to view URL] = ‘Add’, then?
? ? ? ? ? ? ? ? 1. Read Worksheet1.(No, Code, Program)?
? ? ? ? ? ? ? ? 2.? Search Worksheet2 for Worksheet1.(No, Code, Program)?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? i.? If found, SUB FOUND( )?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ii.? If not found, SUB NOT FOUND ( )
? ? ? ? If [login to view URL] = ‘Remove’, then?
? ? ? ? ? ? ? ? 1.? Read Worksheet1.(No, Code, Program)?
? ? ? ? ? ? ? ? 2.? Search Worksheet2 for Worksheet1.(No, Code, Program)?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? iii. If found,?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 1.? Copy entire row to worksheet3?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 2. update [login to view URL] to ‘NOT REMOVED’?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 3.? highlight row in red?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? iv.? If not found?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 1.? Copy entire row to worksheet3?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 2.? update [login to view URL] to ‘REMOVED’?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 3.? highlight row light blue
? ? ? ? If [login to view URL] = ‘Update’, then?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 1.? Read Worksheet1.(No, Code, Program)?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? 2.? Search Worksheet2 for Worksheet1.(No, Code, Program)?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? v.? ? If found, SUB FOUND( )?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? vi.? If not found, SUB NOT FOUND ( )
SUB FOUND ( )
1.? Compare each cell
2.? If cells are identical and [login to view URL] = ‘Add’?
? ? ? ? ? ? ? ? i.? ? Copy the row from worksheet1 to worksheet3?
? ? ? ? ? ? ? ? ii.? ? Change [login to view URL] to ‘ADDED’?
? ? ? ? ? ? ? ? iii.? Highlight row light green
3.? ? If cells are identical and [login to view URL] = ‘Update’?
? ? ? ? ? ? ? ? i.? Compare each cell from worksheet1 with worksheet2?
? ? ? ? ? ? ? ? ? ? ? ? 1.? ? If identical:?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? a.? Copy the row from worksheet1 to worksheet3?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? b.? Change [login to view URL] to ‘UPDATED’?
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? c.? Highlight row light yellow
4.? ? If one or more cells do not match:?
? ? ? ? ? ? ? ? ? ? ? ? a.? ? Copy the row from worksheet1 to worksheet3?
? ? ? ? ? ? ? ? ? ? ? ? b.? ? Bold the different cells?
? ? ? ? ? ? ? ? ? ? ? ? c.? ? ? Highlight row in red?
? ? ? ? ? ? ? ? ? ? ? ? d.? ? ? Change [login to view URL] to ‘UPDATE ERROR’
SUB NOT FOUND ( )
1.? Copy the row from worksheet1 to worksheet3
2.? Change [login to view URL] to ‘MISSING’
3.? Highlight row light red
?
Projekt-ID: 3760806
Über das Projekt
9 Vorschläge
Remote Projekt
Aktiv vor 15 Jahren
Möchten Sie etwas Geld verdienen?
Vorteile einer Ausschreibung auf Freelancer
Legen Sie Ihr Budget und Ihren Zeitrahmen fest
Für Ihre Arbeit bezahlt werden
Skizzieren Sie Ihren Vorschlag
Sie können sich kostenlos anmelden und auf Aufträge bieten
9 Freelancer bieten im Durchschnitt $8 USD für diesen Auftrag
$8,50 USD in 17 Tagen
4,9 (350 Bewertungen) $8,50 USD in 17 Tagen
4,9 (80 Bewertungen) $8,50 USD in 17 Tagen
4,7 (43 Bewertungen) $8,50 USD in 17 Tagen
4,8 (14 Bewertungen) $6,80 USD in 17 Tagen
4,9 (2 Bewertungen) $8,50 USD in 17 Tagen
5,0 (2 Bewertungen) $8,50 USD in 17 Tagen
4,5 (1 Bewertung) $8,50 USD in 17 Tagen
0,0 (0 Bewertungen)