Excel makro - barevné porovnání obsahu 2 doc

[Zd3n3k]

Zdravím všechny experty přes Excel,

prosím můžete mi někdo poradit jak vytvořít makro na následující případ?

Mám 2 dokumenty. V dokumentech jsou čísla (ceník). Obsah 1 dokumentu je neměnný, obsah 2 dokumentu se mění. Potřeboval bych vytvořit makro, které po stisknutí tlačítka v doc 2 zkontroluje čísla v doc 1 a dle toho označí čísla v doc 2 barevně.

Pokud je hodnota v daných buňkách doc 2 < doc 1 / v doc 2 označ buňky červeně.
Pokud je hodnota v daných buňkách doc 2 = doc 1 / v doc 2 označ buňky oranžově.
Pokud je hodnota v daných buňkách doc 2 > doc 1 / v doc 2 označ buňky zeleně.
Pokud je hodnota v daných buňkách doc 2 = 0 (prázdná buňka) nic nedělej.

Děkuji všem za help.

[Reklama]

[Branscombe]

To by nemělo být složité, přilož demo soubory abychom mohli definovat oblasti atd..

[Zd3n3k]

Umístění kolonek se němění, mění se pouze obsah. V demo souborech jsou to kolonky B - 2,3,4.

Data_1.xlsx

(8.24 KiB) Staženo 65 x

Data_2.xlsx

(8.21 KiB) Staženo 49 x

[Branscombe]

Do standartního modulu do souboru "Data_2.xlsx" vlož následující makro:

Kód: Vybrat vše

Option Explicit

Sub porovnej()

Dim Cll As Range, Cll2 As Range, i As Variant

Set Cll = Workbooks("Data_1").Worksheets("Cenik").Range("B2")
Set Cll2 = Workbooks("Data_2").Worksheets("Cenik").Range("B2")

For i = 1 To Workbooks("Data_1").Worksheets("Cenik").Cells(Worksheets("Cenik").Rows.Count, 1).End(xlUp).Row - 1

If Cll2.Value > Cll.Value Then

  With Cll2.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent3
    .TintAndShade = 0
    .PatternTintAndShade = 0
    End With
   
ElseIf Cll2.Value = Cll.Value Then

  With Cll2.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 49407
    .TintAndShade = 0
    .PatternTintAndShade = 0
  End With
   
ElseIf Cll2.Value < Cll.Value Then

  With Cll2.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 192
    .TintAndShade = 0
    .PatternTintAndShade = 0
  End With

End If

Set Cll = Cll.Offset(1, 0)
Set Cll2 = Cll2.Offset(1, 0)

Next i

Set Cll = Nothing
Set Cll2 = Nothing

End Sub



V případě jakýchkoliv dotazů dej vědět ...

[Zd3n3k]

Super funguje. Název worksheetu musí být celý tedy data_1.xlsx. Díky moc.

[Zd3n3k]

Jak v tomto makru nastavím oblast buněk pro kterou se to má počítat? Je mi tředa o sloupec B2 - B6, B12-B16, D5 - D7, a tak dále ... Díky za radu ...