Betinget formatering mellem 2 ark - evt. VBA

du kan godt bruge betinget formatering mellem ark - dog kræver det at du navngiver cellerne! (ctrl+f3)

Nu er det alle cellerne i arkene der skal sammenlignes - såååå :-)

Sub SammenlignArk()
Dim vArk()
Dim raekker, kolonner, i, o As Long

Sheets("Ark1").Select

raekker = Range("A65000").End(xlUp).Row
kolonner = Range("IV1").End(xlToLeft).Column

ReDim vArk(raekker - 1, kolonner - 1)

Application.ScreenUpdating = False

For i = 0 To kolonner - 1
    For o = 0 To raekker - 1
        vArk(o, i) = Cells(o + 1, i + 1).Value
    Next o
Next i

Sheets("Ark2").Select
For i = 0 To kolonner - 1
    For o = 0 To raekker - 1
        If Not Cells(o + 1, i + 1).Value = vArk(o, i) Then Cells(o + 1, i + 1).Interior.Color = vbYellow
    Next o
Next i

Application.ScreenUpdating = True
End Sub

Det er 1 måde at gøre det på !

mit bud:

Sub SammenlignArk()
Dim AD As String, FArk As Variant, Sammenlign As Variant, I As Long, K As Integer, N As Integer
    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
          Cells(I, N).Interior.Color = vbYellow
          Else
          Cells(I, N).Interior.ColorIndex = xlNone
          End If
        Next N
    Next I

Application.ScreenUpdating = True
End Sub

Tak for hjælpen begge!

Jeg har anvendt Brynils, da dette var den første og den virker helt efter hensigten.

Kabbak - Jeg håber det er i orden at jeg giver point'ne til Brynil!

Smider du et svar Brynil?

TVC

Må desværre beklage brynil men det var kabbaks der virkede - fik byttet om på jeres makroer :-(

Jeg kan ikke se at din (brynil) farver cellerne der differerer fra cellerne i det andet ark.

kabbak smider du et svar?

TVC

Det er helt iorden. kabbak's er også kortere. (Altså, makroen) ;)) Sorry!

Jeg ku nu godt tænke mig at vide hvor min fejler, for den fungerede fint nok på min testside. Måske kabbak har en idé om hvor den kan forårsage fejl?!

brynil > ved mig virker din også, men markerer i ark2.

min markerer i ark1

forresten en ny kode, den skulle være hurtigere

Sub SammenlignArk()
ST = Now()
Dim AD As String, FArk As Variant, Sammenlign As Variant, i As Long, K As Integer, N As Integer

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
        Cells(i, N).Interior.Color = vbYellow
          End If
        Next N
    Next i

Application.ScreenUpdating = True
MsgBox K * UBound(FArk) & " celler tog  " & Format(Now - ST, "ss") &  " sekunder"
End Sub

I er rigtig gode begge to, men der er lige en krølle på spørgsmålet:

hvis der står en værdi i ark 1 men ikke i ark 2, kan det så også markeres med gult i ark 2, at der "mangler" en værdi i f.t. ark 1? Det gør makroen ikke lige i øjeblikket.

Mvh. TVC

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
      If FArk(i, N) <> "" And Sammenlign(i, N) = "" Then
      Sheets("Ark2").Cells(i, N).Interior.Color = vbYellow
      End If
          End If
        Next N
    Next i

Application.ScreenUpdating = True
MsgBox K * UBound(FArk) & " celler tog  " & Format(Now - ST, "ss") & " sekunder"
End Sub

Kabbak, nu markerer den kun, hvis der mangler en værdi, men kan den kobles sammen, så den BÅDE markerer celler, der er forskellig fra samt markerer, hvis der mangler en værdi?

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

Tusind tak, nu virker det helt perfekt!

Mvh. TVC