Sammenlign to regneark

Ved hjelp av makroen nedenfor kan man sammenligne innholdet i to regneark. Resultatet er en egen rapport som viser de forskjellige cellene.

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 = "Lager rapporten..."
    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 = "Sammenligner celler " & _
            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 = "Formaterer rapporten..."
    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 & " celler inneholder forskjellige formler!", _
        vbInformation, "Sammenlign " & _
        ws1.Name & " med " & ws2.Name
End Sub

Her er et par eksempler på hvordan makroen kan benyttes:

Sub TestCompareWorksheets()
    ' sammenlign to forskjellige regneark i den aktive arbeidsboken
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
    ' sammenlign to forskjellige regneark i to forskjellige arbeidsbøker
    CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
        Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub

Sub TestCompareWorksheets2()
' lar brukeren velge to arbeidsbøker
' sammenligner det første regnearket i arbeidsbøkene
Dim strFile(1 To 2) As String, wb(1 To 2) As Workbook, i As Long
    strFile(1) = "Excel arbeidsbøker (*.xls),*.xls,Alle filer (*.*),*.*"
    strFile(2) = strFile(1)
    For i = 1 To 2
        strFile(i) = Application.GetOpenFilename(strFile(i), 1, _
            "Velg arbeidsbok " & i, , False)
        If Len(strFile(i)) < 6 Then Exit Sub ' ingen fil er valgt
    Next i
    
    Application.ScreenUpdating = False
    For i = 1 To 2
        Set wb(i) = Workbooks.Open(strFile(i), True, True)
    Next i
        
    ' sammenlign det første regnearket i de to arbeidsbøkene
    CompareWorksheets wb(1).Worksheets(1), wb(2).Worksheets(1)
    
    For i = 1 To 2
        wb(i).Close False ' lukk arbeidsboken uten å lagre endringer
        Set wb(i) = Nothing
    Next i
    Erase strFile
    
    Application.ScreenUpdating = True
End Sub

Dokumentet er sist oppdatert 2005-06-09 17:58:03 Utskriftsvennlig versjon

Brukerkommentarer:

Ole P. fra Trondheim skrev (2006-05-09 23:15:50 CET):

Re: Problemer med denne makroen (2)
Her finner du en beskrivelse av hvordan makroene på disse sidene kan benyttes.
De to makroeksemplene du har sett på vil være egnet til å sammenligne to regenarkområder og vise de konkrete cellene som er forskjellige.
Dersom du ønsker å sammenligne lister med f.eks. produktnummer og finne ut hvilke nummer i en liste som ikke finnes i en annen liste er ikke disse to makroene spesielt godt egnet.

KG fra Bergen skrev (2006-05-09 13:04:51 CET):

Problemer med denne makroen (2)
Beklager - det er egentlig makroen "Sammenlign to regnearkområder" jeg har prøvd.

KG fra Bergen skrev (2006-05-09 12:53:39 CET):

Problemer med denne makroen
Hei
Jeg skal sammenligne varetekst i to regneark.
Det ene arket ("SUMMERING") er et summeringsark hvor jeg har kjedet sammen artnr og varetekst tot ca 900 rader. Det andre arket ("LISTE") er summering av varelageret fra syv fabrikker som også er kjedet sammen - og inneholder vel 2500 rader. Det tar fyktelig lang tid å kontrollere manuelt - for det jeg har behov for er å se om arket "LISTE" har endret seg med artikler som har gått ut eller kommet til. Makroen på denne siden tror jeg kunne ha passet, men jeg er ikke noen ekspert på området og får den ikke til. Antar det ikke er så enkelt som bare å lime den inn i arbeidsboken.