Oblikovanje celice v tabeli

[sonofagun]

Pozdravljeni.

Imam sledeč problem: v tabeli 5x15 (npr.: C3:Q7) imam zapisane različne vrednosti (številke). V celico npr.: G10 pa vpisujem vrednosti, ki so v prej omenjeni tabeli. Želel bi, da ko v celico G10 vnesem neko vrednost iz tabele, se tej vrednosti v tabeli spremeni oblikovanje (npr. pobarva ozadje, spremeni pisava v Bold, itd) in potem takšno oblikovanje celice v tabeli tudi ostane, medtem ko bi v celico G10 vpisal neko novo vrednost iz tabele itd... Kakšna pomoč, predlog?

Lep pozdrav

P.S. Podoben primer bi bil "prečrtavanje" izžrebanih številk pri npr. tomboli, vendar imam tukaj drugo vrsto podatkov, iz katerih moram ugotoviti kateri so bili uporabljeni (prečrtani) in kateri ne.

[admin]

Tega se z Excelovimi formulami ne da narediti, ker formula nikoli ne more vplivati na drugo celico, zatorej je to potrebno rešiti z makrom.

Makro pa je relativno preprost. V dogodek Worksheet_Change morate zapisati kodo, ki najde številko in celico obarva. V forumu bost našli kar nekaj tematik, ki obravnavajo omenjen dogodek.

Npr. Zagon makra ob spremembi vrednosti v celici in Maximalna vrednost v celici, če uporabite iskanje in vpišete Worksheet_Change pa jih boste našli še mnogo več.

[sonofagun]

Z izdatno pomočjo foruma in prijatelja sem prišel do tega:

Koda: Izberi vse

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Celica1 As Variant

Vrednost = Range("G10").Value

Celica1 = Range("C3:Q7").Value

 nasel = False
 
    For Each cell In Celica1
        
    If (cell = Vrednost) Then
            nasel = True
            aktivna_vrstica = Target.Row
            aktivna_stolpec = Target.Column
            ActiveSheet.Cells(aktivna_vrstica, aktivna_stolpec).Select
            End If
   Next cell

   If (nasel = False) Then
    MsgBox ("Vrednosti " & Vrednost & " ni v tabeli!")
   End If
 
    
' oblikovanje

    With Selection.Borders(xlDiagonalDown)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlDiagonalUp)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

Ampak to še vseeno ni to... Obarva mi celico G10 (kjer vpisujem podatke in ne celice v tabeli, ki ima enako vrednost!!!)
http://picasaweb.google.com/gregor.koko ... directlink

Predlog?

[admin]

Predlog?

Popravite makro ... No glavna napaka vašega makra je, da skušate spremeniti aktivno celico, kar v odzivu na dogodek ne morete storiti... Spodaj imate pravilen makro:

Koda: Izberi vse

'
'  www.matjazev.net
'   november 2010
'
Private Sub Worksheet_Change(ByVal Target As Range)
  If (Intersect(Target, Range("G10")) Is Nothing) Then Exit Sub

  Dim iskanaVrednost: iskanaVrednost = Range("G10").Value
  Dim obmocje As Range: Set obmocje = Range("C3:Q7")
  Dim celica, nasel
  
  nasel = False
  For Each celica In obmocje
    If (celica.Value = iskanaVrednost) Then
      nasel = True

      With celica
        With .Borders
          .LineStyle = xlContinuous
          .ColorIndex = 0
          .Weight = xlThin
        End With
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
        With .Interior
          .Pattern = xlSolid
          .PatternColorIndex = xlAutomatic
          .Color = 255
        End With
      End With
    End If
  Next

  If (nasel = False) Then
   MsgBox ("Vrednosti " & iskanaVrednost & " ni v tabeli!")
  End If
End Sub

[sonofagun]

Stvar deluje odlično!!! Na koncu sem dodal samo še eno vrstico zapisa, da ostanem vedno v celici G10, ampak to so že lepotni popravki

Še enkrat več najlepša hvala za pomoč.

Lep pozdrav, Gregor

[admin]

No, saj makro sem vam napisal zato, ker ste se potrudili tudi sami in ga zapisali...