preštetje barv pisav

Pomoč pri izdelavi makrov
Odgovori
luka_k
Prispevkov: 61
Pridružen: So Okt 01, 2005 9:00 pm

preštetje barv pisav

Odgovor Napisal/-a luka_k »

pozdravljeni

zanima me,če je možno prešteti,koliko različnih barv pisav nastopa v
celicah od a1:c100.primer- če so v tem območju zelena pisava,rdeča pisava,modra pisava,potem je rezultat 3.(rezultat izpiši v celico d1)
upam,da ne bo prehudo za forum takšnega kova,kot je ta.
za odgovor se zahvaljujem.

lp
cedra
Prispevkov: 264
Pridružen: Po Jul 25, 2005 11:11 pm
Kraj: Kamnik

Odgovor Napisal/-a cedra »

Spet sem uporabil makro, kjer sem že pomagal nekomu:
http://www.matjazev.net/forum/viewtopic.php?t=754
Treba ga je bilo samo prilagoditi vašim zahtevam:

Koda: Izberi vse

Sub Razlicni_zapisi_barve()
     
    Dim UniqueList()    As String
    Dim x               As Long
    Dim Rng1            As Range
    Dim c               As Range
    Dim Unique          As Boolean
    Dim y               As Long
     
    Set Rng1 = ActiveSheet.Range("A1:C100")
    y = 0
     
    ReDim UniqueList(1 To Rng1.Rows.Count)
     
    For Each c In Rng1
        If Not c.Font.ColorIndex = vbNullString Then
            Unique = True
            For x = 1 To y
                If UniqueList(x) = c.Font.ColorIndex Then
                    Unique = False
                End If
            Next
            If Unique Then
                y = y + 1
                UniqueList(y) = c.Font.ColorIndex
            End If
        End If
    Next
     Cells(1, 4) = y - 1
End Sub
Na koncu makra v predzadnji vrstici odštejem eno, da vam ne upošteva osnovne pisave v kateri piše Excel! Če vam to ne ustreza potem tisti - 1 zbrišite.

Je to tisto, kar ste želeli?
lp,

cedra
luka_k
Prispevkov: 61
Pridružen: So Okt 01, 2005 9:00 pm

Odgovor Napisal/-a luka_k »

pozdravljeni Cedra :wink:

ja,pravilno ste me razumeli in makro je ravno pravšnji.hvala.
me pa še nekaj pri tem zanima,namreč ko vse te barve pisav(vrednosti celic)izbrišem,mi še vedno kaže rezulat,kakršen je bil prej ko so celice vsebovale vrednosti.v bistvu ta makro verjetno šteje oblikovanje celic,ki pa ostane,dokler ga ne spremeniš.
zanima me,oziroma ali je kakšna elegantna rešitev,da bi ta makro deloval,samo takrat ko bi bile vrednosti v tem obsegu sicer bi kazal vrednost nič.nevem,Cedra če ste me razumeli,bom pa vesel če se vam
utrne zopet kakšna ideja.
za odgovor se vsekakor zahvaljujem


lp
kljuka13
Prispevkov: 257
Pridružen: Po Sep 10, 2007 4:29 pm
Kraj: Maribor

Odgovor Napisal/-a kljuka13 »

Najbolje bo tako:
  • Pojdite v VBA in na levi izberite ThisWorkbook
  • Zgoraj v prvem polju izberite Workbook v drugem pa SheetChange
  • V to procedure vpišite sledeč makro, ki ga je predlagal (a) Cedra
Makro se bo pognal ob vsaki spremembi. To pa je lahko težava ob velikem številu različnih barv in bi se zato Excel zelooo upočasnil. :(
[img]http://shrani.si/f/3t/YL/4W2P37B9/office.gif[/img]
[img]http://shrani.si/f/12/aa/1rt1wj6i/1/userbardionaea.gif[/img]
[img]http://shrani.si/f/3D/nN/3RQySBCl/vista-copy.gif[/img]
cedra
Prispevkov: 264
Pridružen: Po Jul 25, 2005 11:11 pm
Kraj: Kamnik

Odgovor Napisal/-a cedra »

Če sem vas prav razumel naj bi npr. takrat ko pobrišete vrednosti vseh celic z rdečo pisavo, ne bilo npr. rezultat 4 (zelena, modra, črna, rdeča) ampak 3!
Če je tako potem preizkusite z popravljenim makrom. Če pa boste spet vpisali v "rdečo" celico, pa spet 4!?!

Koda: Izberi vse

Sub Razlicni_zapisi_barve()
     
    Dim UniqueList()    As String
    Dim x               As Long
    Dim Rng1            As Range
    Dim c               As Range
    Dim Unique          As Boolean
    Dim y               As Long
     
    Set Rng1 = ActiveSheet.Range("A1:C20")
    y = 0
     
    ReDim UniqueList(1 To Rng1.Rows.Count)
     
    For Each c In Rng1
        If Not c.Font.ColorIndex = vbNullString Then
            Unique = True
            For x = 1 To y
                If UniqueList(x) = c.Font.ColorIndex Or c.Value = "" Then
                    Unique = False
                End If
            Next
            If Unique Then
                y = y + 1
                UniqueList(y) = c.Font.ColorIndex
            End If
        End If
    Next
     Cells(1, 4) = y - 1
End Sub
Je to to?
lp,

cedra
luka_k
Prispevkov: 61
Pridružen: So Okt 01, 2005 9:00 pm

Odgovor Napisal/-a luka_k »

pozdravljen Cedra

mislim ,da me niste razumeli...

imam štiri celice in vrednosti v njih :
(in v vsaki celici je drugačna pisava )
-zelena
-modra
-črna
-rdeča
se pravi rezultat bi moral biti 4.in tudi je.vendar ko zbrišem eno vrednost
v celici je še vedno vrednost 4,morala pa bi biti 3.a razukmete?
torej oblikovanje celice je še vedno ostalo in je šteje,čeprav je celica
prazna.a bi se dalo tukaj še kar narediti?

poskusil bom vaš makro pripeti v Worksheet_Change vendar se bojim,da mi bo delal težave.
še bom vesel vaše pomoči.

lp
luka_k
Prispevkov: 61
Pridružen: So Okt 01, 2005 9:00 pm

Odgovor Napisal/-a luka_k »

ups Cedra :oops: :oops:

se opravičujem,vaš makro je sedaj to.kar potrebujem.
včasih sem malo prehiter......
nisem mislil,da boste kar takoj v prvem razumeli :lol:

še enkrat hvala in

lp :wink:
cedra
Prispevkov: 264
Pridružen: Po Jul 25, 2005 11:11 pm
Kraj: Kamnik

Odgovor Napisal/-a cedra »

Saj moj popravljen makro deluje točno tako kot vi zdaj želite. Ali ste ga sploh preizkusili?
Pardon, med tem ko sem pisal ste že preizkusili in zdaj je O.K. :lol:
lp,

cedra
Odgovori