23. marts 2008 - 19:47Der er
3 kommentarer og 1 løsning
Sammenligning af to worksheets
Hej
Jeg har en kæmpe datamængde placeret i to worksheets. Jeg vil gerne have et script der løber de to worksheets igennem, og sammenligner data. Sammenligningen må gerne være på række niveau.
Da jeg ikke er særlig skrap til VB-script - Excell har jeg brug lidt expert bistand. Overordnet set skal scriptet kunne: - Loope fra første til sidste række. - Sammenligne række nr. x i worksheet 1 med række nr. x i worksheet 2 - Hvis er diferencer, markere den givne række - eks. ved at ændre baggrundsfarven.
Public Function LastRow(Ark As Worksheet) As Long LastRow = Ark.UsedRange.Rows.Count End Function
Public Function LastColumn(Ark As Worksheet) As Integer LastColumn = Ark.UsedRange.Columns.Count End Function
Sub KontrollerArk()
Dim FraArk As Worksheet Dim TilArk As Worksheet Dim FraArk_Rw_Max, TilArk_Rw_Max, RwMax As Long Dim FraArk_Col_Max, TilArk_Col_Max, ColMax As Long Dim Rw As Long Dim Col As Long
Set FraArk = Worksheets("Ark1") ' Her erstattes Ark 1 med navn på det første ark Set TilArk = Worksheets("Ark2") ' Her erstattes Ark 1 med navn på det andet ark
' Nulstil nuværende markering af ark (farve sættes til blank) FraArk.Cells.Interior.ColorIndex = xlNone TilArk.Cells.Interior.ColorIndex = xlNone
' Definer værdierne for arket (hvor mange rækker og kolonner) FraArk_Rw_Max = LastRow(FraArk) TilArk_Rw_Max = LastRow(TilArk) FraArk_Col_Max = LastColumn(FraArk) TilArk_Col_Max = LastColumn(TilArk)
' Find ud af hvilket ark der har flest rækker If FraArk_Rw_Max > TilArk_Rw_Max Then RwMax = FraArk_Rw_Max Else RwMax = TilArk_Rw_Max End If
' Find ud af hvilket ark der har flest kolonner If FraArk_Col_Max > TilArk_Col_Max Then ColMax = FraArk_Col_Max Else ColMax = TilArk_Col_Max End If
For Rw = 1 To RwMax For Col = 1 To ColMax If FraArk.Cells(Rw, Col).Value <> TilArk.Cells(Rw, Col).Value Then FraArk.Cells(Rw, Col).Interior.ColorIndex = 36 ' marker celle i FraArk TilArk.Cells(Rw, Col).Interior.ColorIndex = 36 ' Marker celle i TilArk End If Next Col Next Rw End Sub
Tak for svaret. Sammen med et andet svar, og lidt opfindsomhed har jeg udviddet løsningen: Public Function LastRow(Ark As Worksheet) As Long LastRow = Ark.UsedRange.Rows.Count End Function
Public Function LastColumn(Ark As Worksheet) As Integer LastColumn = Ark.UsedRange.Columns.Count End Function
Sub KontrollerArk()
Dim FraArk As Worksheet Dim TilArk As Worksheet Dim FraArk_Rw_Max, TilArk_Rw_Max, RwMax As Long Dim FraArk_Col_Max, TilArk_Col_Max, ColMax As Long Dim Rw As Long Dim Col As Long Dim Col2 As Long Dim TotalErr As Integer Dim RowErr As Integer Dim RowErrFlag As Boolean
'Delete resultsheet Application.DisplayAlerts = False If Worksheets.Count > 2 Then Worksheets(3).Delete Application.DisplayAlerts = True
' Set Worksheets Set FraArk = Worksheets(1) ' Her erstattes Ark 1 med navn på det første Ark Set TilArk = Worksheets(2) ' Her erstattes Ark 1 med navn på det andet Ark Set ResultSheet = Worksheets(3) ' Her udskrives resultater, ResultSheet.Name = "Results"
' Nulstil nuværende markering af ark (farve sættes til blank) FraArk.Cells.Interior.ColorIndex = xlNone TilArk.Cells.Interior.ColorIndex = xlNone ResultSheet.Cells.Interior.ColorIndex = xlNone
' Definer værdierne for arket (hvor mange rækker og kolonner) FraArk_Rw_Max = LastRow(FraArk) TilArk_Rw_Max = LastRow(TilArk) FraArk_Col_Max = LastColumn(FraArk) TilArk_Col_Max = LastColumn(TilArk)
' Find ud af hvilket ark der har flest rækker If FraArk_Rw_Max > TilArk_Rw_Max Then RwMax = FraArk_Rw_Max Else RwMax = TilArk_Rw_Max End If
' Find ud af hvilket ark der har flest kolonner If FraArk_Col_Max > TilArk_Col_Max Then ColMax = FraArk_Col_Max Else ColMax = TilArk_Col_Max End If
'Opbyg ResultSheet ResultSheet.Cells(1, 1).Value = "Række" ' Columm Række is added For Col2 = 1 To ColMax If FraArk.Cells(1, Col2).Value <> "" Then ResultSheet.Cells(1, Col2 + 1).Value = FraArk.Cells(1, Col2).Value Else ResultSheet.Cells(1, Col2 + 1).Value = TilArk.Cells(1, Col2).Value ResultSheet.Cells(1, Col2 + 1).Interior.ColorIndex = 3 ' Marker celle i ResultSheet End If Next Col2
'Udfør sammenligning TotalErr = 0 RowErr = 0 For Rw = 1 To RwMax RowErrFlag = False
For Col = 1 To ColMax If FraArk.Cells(Rw, Col).Value <> TilArk.Cells(Rw, Col).Value Then TotalErr = TotalErr + 1 FraArk.Rows(Rw).Interior.ColorIndex = 6 ' marker celle i FraArk FraArk.Cells(Rw, Col).Interior.ColorIndex = 3 ' marker celle i FraArk TilArk.Rows(Rw).Interior.ColorIndex = 6 ' marker Række i TilArk TilArk.Cells(Rw, Col).Interior.ColorIndex = 3 ' Marker celle i TilArk If Not RowErrFlag Then RowErr = RowErr + 1 RowErrFlag = True For Col2 = 1 To ColMax ResultSheet.Cells((3 * RowErr), 1).Value = Rw ResultSheet.Cells((3 * RowErr), Col2 + 1).Value = FraArk.Cells(Rw, Col2).Value ResultSheet.Cells((3 * RowErr) + 1, Col2 + 1).Value = TilArk.Cells(Rw, Col2).Value Next Col2 End If ResultSheet.Cells((3 * RowErr) + 1, Col + 1).Interior.ColorIndex = 3 ' Marker celle i ResultSheet ResultSheet.Cells((3 * RowErr), Col + 1).Interior.ColorIndex = 3 ' Marker celle i ResultSheet End If Next Col Next Rw FraArk.Columns.AutoFit ' FraArk.Rows.AutoFit TilArk.Columns.AutoFit TilArk.Rows.AutoFit ResultSheet.Columns.AutoFit
'Make Remarks Dim ResultLine As Long ResultLine = (3 * RowErr) + 3 ResultSheet.Cells(ResultLine, 1).Value = "Antal fejl rækker" ResultSheet.Cells(ResultLine, 2).Value = RowErr ResultSheet.Cells(ResultLine + 1, 1).Value = "Antal fejl i alt" ResultSheet.Cells(ResultLine + 1, 2).Value = TotalErr MsgBox ("Failed rows: " & RowErr & vbCrLf & _ "Total errors: " & TotalErr) End Sub
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
