27. januar 2007 - 11:18Der er
4 kommentarer og 1 løsning
Sammenligning af to filer
Hej Expert, jeg har tidligere anvendt en macro, der kan sammenligne to excelark i Excel, jf. nedenstående. Her viser den gule felter, hvor der er forskel i arkene. Hvordan kan jeg lave en makro, der kan sammenligne to FILER i stedet, hvor der markeres med en farve, hvor der er forskelle i filerne?
Sub SammenlignArk() ST = Now() Dim AD As String, FArk As Variant, Sammenlign As Variant, i As Long, K As Integer, N As Integer
Sheets("Ark1").Cells.Interior.ColorIndex = xlNone Sheets("Ark2").Cells.Interior.ColorIndex = xlNone AD = Sheets("Ark1").Range("A1").SpecialCells(xlLastCell).Address K = Sheets("Ark1").Range("A1").SpecialCells(xlLastCell).Column FArk = Sheets("Ark1").Range("a1:" & AD)
Sammenlign = Sheets("Ark2").Range("a1:" & AD)
Application.ScreenUpdating = False For i = 1 To UBound(FArk) For N = 1 To K If FArk(i, N) <> Sammenlign(i, N) Then Sheets("Ark1").Cells(i, N).Interior.Color = vbYellow Sheets("Ark2").Cells(i, N).Interior.Color = vbYellow If FArk(i, N) <> "" And Sammenlign(i, N) = "" Then Sheets("Ark2").Cells(i, N).Interior.Color = vbRed End If End If Next N Next i
Application.ScreenUpdating = True MsgBox K * UBound(FArk) & " celler tog " & Format(Now - ST, "ss") & " sekunder" End Sub
Danmark vil mindske afhængigheden af globale techgiganter, men det kræver mere end politiske formuleringer og strategier, understreger PROSA’s formand Niels Bertelsen.
'Ret T1,T2 til dine filnavne samt evt. Ark1 og område A1:R30 til aktuelle 'subben farver matchende værdier blå 'OBS begge filer skal være åbne
Sub sammenlign() Dim c, x Dim tst As String Dim tst2 As String
For Each c In Workbooks("T1").Worksheets("Ark1").Range("A1:R30").Cells c.Activate tst = c.Value If tst = "" Then GoTo ny For Each x In Workbooks("T2").Worksheets("Ark1").Range("A1:R30").Cells tst2 = x.Value If tst = tst2 Then ActiveCell.Font.ColorIndex = 3
denne farver baggrund rød i celler som ikke matcher obs sammenligner første ark (1) i begge filer ret 1 til 2 for næste ark husk begge filer åbnet
Sub sammenlign() Dim c, x Dim tst As String Dim tst2 As String
For Each c In Workbooks("T1").Worksheets(1).Range("A1:R30").Cells If c.Value <> Workbooks("T2").Sheets(1).Range(c.Address) Then Range(c.Address).Interior.ColorIndex = 3 Else Range(c.Address).Interior.ColorIndex = xlNone End If Next
Super - tusind tak. Det virker! Har tilføjet en lille smule, så den kan læse på alle sheets. Lægger du et svar ;)
Sub sammenlign() Dim c, x Dim tst As String Dim tst2 As String
For i = 1 To Sheets.Count
For Each c In Workbooks("T1").Sheets(i).Range("A1:R30").Cells If c.Value <> Workbooks("T2").Sheets(i).Range(c.Address) Then Workbooks("T1").Sheets(i).Range(c.Address).Interior.ColorIndex = 3 Workbooks("T2").Sheets(i).Range(c.Address).Interior.ColorIndex = 3 Else Workbooks("T1").Sheets(i).Range(c.Address).Interior.ColorIndex = xlNone Workbooks("T2").Sheets(i).Range(c.Address).Interior.ColorIndex = xlNone End If Next
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.
