Makro nebo podmíněné formátování Vyřešeno

[Branscombe]

Ahoj, v příloze je soubor kde bych potřeboval naprogramovat formátování buněk tak jak je naznačeno a nevím zda-li pomocí VBA nebo pomocí podmíněného formátování. Co je jednodušší ??

Zadání - pokud je ve sloupci "C" je jakákoliv hodnota naformátuj buňku příslušného řádku a sloupce (dle sloupce A a B) v oblasti G2:G77
Příklad pro první řádek: Datum = 2010-01 což je sloupec "M", Kód = 110 což je řádek "7", ve sloupci C <> "", naformátuj buňku "M7"

Myslím si že by to šlo přes podmíněné formátování, ale nevím jestli by to nebylo moc složité.
Doufám že jsem to napsal srozumitelně a předem díky za rady...

[Reklama]

[navstevnik]

Podminene formatovani by bylo mozno pouzit za predpokladu, ze vyskyt data ve sloupci A:A je jedinecny. Protoze tomu tak neni, je navrzena procedura, ktero je zapotrebi zavolat pri zmenach v oblastech dat.
Procedura odstrani formatovani v bloku G2:R16 a pak postupne ve smyckach hleda pozadovanou shodu pro formatovani v bloku G2:R16.
Vzhledem k jednoznacnemu vymezeni jednotlivych bloku dat v ukazce, jsou tyto bloky v procedure staticke.

Kód: Vybrat vše

Option Explicit

Sub PodmineneFormatovani()
  Dim DBlk As Range, DCll As Range
  Dim KBlk As Range, KCll As Range, OfsC As Integer
  Dim HBlk As Range, HCll As Range
  With Worksheets("list1")
    With .Range("g2:r16") ' ostranit stary format
      .Interior.ColorIndex = xlNone
      .Font.Bold = False
    End With
    Set DBlk = .Range("a2:a16")  ' blok bunek ve sloupci A:A - datum
    Set KBlk = .Range("e2:e16")  ' blok bunek ve sloupci E:E - kod
    Set HBlk = .Range("g1:r1")  ' blok bunek v radku G1:R1 - hlavicky sloupcu
  End With
  OfsC = 2
  For Each HCll In HBlk.Cells  ' prochazi blok hlavicek
    For Each DCll In DBlk.Cells ' prochazi blok Datum
      If DCll.Value = HCll.Value Then ' pri shode
        For Each KCll In KBlk.Cells ' prochazi blok Kod
          If KCll.Value = DCll.Offset(0, 1).Value Then ' pri shode
            With KCll.Offset(0, OfsC) ' vlozi format bunky pozadi a font
              .Interior.ColorIndex = 6
              .Font.Bold = True
            End With
          End If
        Next KCll
      End If
    Next DCll
    OfsC = OfsC + 1 ' ofset pro dalsi sloupec v bloku G2:R16
  Next HCll
  Set KCll = Nothing
  Set KBlk = Nothing
  Set DCll = Nothing
  Set DBlk = Nothing
  Set HCll = Nothing
  Set HBlk = Nothing
End Sub

[Branscombe]

Super, díky moc ...

[Branscombe]

Ahoj, nějako mi to přestalo fungovat a nevím proč. Soubor v příloze. Rád bych pochopil kde jsem udělal chybu, tak jestli můžeš tak mi prosím jen naznač kde je problém a já to zkusím předělat sám.

[navstevnik]

Prestalo fungovat v dusledku:
1. zmena sloupce Kod z E:E na D:D a neopravils dusledne v procedure; opraveno.
2. neopravils vychozi hodnotu OfsC v dusledku vyse uvedene zmeny; upraveno v procedure, vychozi hodnota je odvozena od bloku HBlk a KBlk
3.nejednotnost typu vlozenych hodnot kodu ve sloupcich B:B a D:D, nekde cislo a jinde retezec, ukazka mela jednotny typ, takze jsem predpokladal, ze tomu bude tak i nadale; nelze porovnat cislo a retezec, upraveno v procedure, prevod retezce na hodnotu. Doprucuji pred vkladanim hodnoty kodu vyprazdnit sloupce, jednotne naformatovat, bud text nebo vlastni format 000 (tri nuly) a pote vkladat hodnoty kodu, v pripade typu retezec neni 058 totez co 58, totez by melo platit pro hlavicky G1:R1 a sloupec Datum - A:A.
Dale v procedure upravena podminka pro formatovani - pridana neprazdna bunka v G2:Rxx
Upravena a doplnena procedura v dusledku zmeny obsahu sloupcu, osetreni typu Kod a neprazdnych bunek:

Kód: Vybrat vše

Option Explicit

Sub PodmineneFormatovani()
  Dim DBlk As Range, DCll As Range
  Dim KBlk As Range, KCll As Range, OfsC As Integer
  Dim HBlk As Range, HCll As Range
  With Worksheets("list1")
    With .Range("g2:r72")  ' ostranit stary format v G2:Rxx
      .Interior.ColorIndex = xlNone
      .Font.Bold = False
    End With
    Set DBlk = .Range("a2:a72")  ' blok bunek ve sloupci A:A - datum
    Set KBlk = .Range("d2:d72")  ' blok bunek ve sloupci D:D - kod
    Set HBlk = .Range("g1:r1")  ' blok bunek v radku G1:R1 - hlavicky sloupcu
  End With
  OfsC = HBlk.Column - KBlk.Column  ' vychozi hodnota ofsetu sloupcu G:G a K:K
  For Each HCll In HBlk.Cells  ' prochazi blok hlavicek
    For Each DCll In DBlk.Cells  ' prochazi blok Datum
      If DCll.Value = HCll.Value Then  ' pri shode
        For Each KCll In KBlk.Cells  ' prochazi blok Kod
          ' pri shode a neprazne bunce v G2:Rxx
          If Val(KCll.Value) = Val(DCll.Offset(0, 1).Value) And KCll.Offset(0, OfsC) <> vbNullString Then
            With KCll.Offset(0, OfsC)  ' vlozi format bunky pozadi a font
              .Interior.ColorIndex = 6
              .Font.Bold = True
            End With
          End If
        Next KCll
      End If
    Next DCll
    OfsC = OfsC + 1  ' ofset pro dalsi sloupec v bloku G2:Rxx
  Next HCll
  Set KCll = Nothing
  Set KBlk = Nothing
  Set DCll = Nothing
  Set DBlk = Nothing
  Set HCll = Nothing
  Set HBlk = Nothing
End Sub

PS.: mozna bude vhodne pouzit pro bloy dat dynamickou definici, procedura bude nezavisla na poctu radku a sloupcu