ERLANDSEN DATA CONSULTING Excel & VBA Tips

### Disse websidene oppdateres ikke lengre og er kun tilgjengelig for historikken sin skyld.

Klikk her for å gå til den oppdaterte informasjonen.

# 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..."
While Worksheets.Count > 1
Worksheets(2).Delete
Wend
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 makroenHei 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.