Sammenlign to regnearkområder

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

Sub CompareWorksheetRanges(rng1 As Range, rng2 As Range)
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
    If rng1 Is Nothing Or rng2 Is Nothing Then Exit Sub
    If rng1.Areas.Count > 1 Or rng2.Areas.Count > 1 Then
        MsgBox "Kan ikke sammenligne flere områder!", _
            vbExclamation, "Compare Worksheet Ranges"
        Exit Sub
    End If
    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 rng1
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With rng2
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    If lr1 <> lr2 Or lc1 <> lc2 Then
        If MsgBox("De to regnearkområdene du vil sammenligne har forskjellig størrelse!" _
            & Chr(13) & "Vil du fortsette allikevel?", _
            vbQuestion + vbYesNo, "Compare Worksheet Ranges") = vbNo Then Exit Sub
    End If
    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 = rng1.Cells(r, c).FormulaLocal
            cf2 = rng2.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, "Compare Worksheet Ranges"
End Sub

Her er noen eksempler på hvordan makroen kan benyttes:

Sub TestCompareWorksheetRanges()
    ' sammenlign to regnearkområder i det aktive arket i den aktive arbeidsboken
    CompareWorksheetRanges Range("A1:A100"), _
        Range("B1:B100")
    ' sammenlign to regnearkområder i i to forskjellige ark i den aktive arbeidsboken
    CompareWorksheetRanges Worksheets(1).Range("A1:A100"), _
        Worksheets(2).Range("B1:B100")
    ' ' sammenlign to regnearkområder i i to forskjellige ark i to forskjellige arbeidsbøker
    CompareWorksheetRanges ActiveWorkbook.Worksheets(1).Range("A1:A100"), _
        Workbooks("WorkBookName.xls").Worksheets(1).Range("B1:B100")
End Sub

Dokumentet er sist oppdatert 1999-12-20 12:37:25 Utskriftsvennlig versjon