Macro hjælp - sammenligning af 2 celler

Hej

Har brug for lidt hjælp til en Macro (excel)

Min kæreste har to regneark
Regneark1
Regneark2

På hver af disse regneark er der to ark der skal sammenlignes.

Fx. kan det være de indeholder en række personer. Lad os antage at Regneark1, ark1 - indeholder 1000 person navne
og at Regneark2, ark1 - indeholder 900 person navne

Min kæreste skal bruge de navne der er ens. Fx. er der to ved navn Bent Burg så skal dette navn føres over i et nyt ark sammen med alle de andre der er ens.

Jeg har en stump kode der finde dem der er forskellige, dvs. dem der ikke er i det ene men i det andet. Det skal være modsat.

Håber lige en er skarp til at hjælpe mig her


Koden:



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 TestCompareWorksheets()
    ' compare two different worksheets in two different workbooks
    CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
        Workbooks("testbook2.xls").Worksheets("Sheet2")
End Sub



Håber opgaven er forstået? :o)