Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Wpis uzależniony od koloru czcionki

CAVIS · Wysłany: 04-01-2007, 12:39 **Wpis uzależniony od koloru czcionki**

Witam
i proszę o pomoc.

W kolumnie A znajdują się dowolne wpisy w dwóch kolorach, niebieskim i czerwonym:

AAA
AAB
CCC
DEF
itd.

chciałaby, aby np. w następnej kolumnie wpisała się cyfra 1, jeżeli kolor wpisu w danym wierszu jest czerwony.
Wiem, że nie ma takiej funkcji w excel'u.
Podobny problem rozwiązany miałam poprzez makro zamieszczone poniżej. Z tym, iż wartość "B" była wówczas uzależniona od koloru wypełnienia komórki.

Kody makr wpisane w Module1

Rem Makro wpisujące "B" w kolumnie D
Function WpiszB(cell As Range, kolor As Long)
Application.Volatile
If KolorKomorki(cell) = kolor Then
WpiszB = "B"
Else
WpiszB = ""
End If
End Function

Rem Makro w powiązaniu z Makro wpisujące "B" w kolumnie D
Function KolorKomorki(cell As Range) As Long
KolorKomorki = cell.Interior.ColorIndex
End Function

Kody makr wpisane w arkuszu:

Public n As Byte
Function KolorKomorki(cell) As Integer
KolorKomorki = cell.Range("H" & n).Interior.ColorIndex
End Function

Sub WpiszB()
For n = 4 To 171
If KolorKomorki(Cells()) = 6 Then
Cells(n, 4) = "B"
End If
Next n
End Sub

Bartek · ExcelSpec **Pomógł:** 69 razy Posty: 105

Witaj,

Wystarczy w Twoim kodzie zamienić lini:

Kod:

KolorKomorki = cell.Range("H" & n).Interior.ColorIndex

na

Kod:

KolorKomorki = cell.Range("H" & n).Font.ColorIndex

no i oczywiście: WpiszB=1 zamiast "B".

CAVIS · Wysłany: 04-01-2007, 14:13

Witam!

Dziękuję za podjęcie tematu.
Niestety nie działa.
Trzeba też zmienić numer koloru.

Próbuję dołączyć załącznik, lecz nie wiem czy mi sie to uda. Już widzę, że nie, ponieważ rozszerzenie xls jest niedozwolone. Dlaczego?

Public n As Byte
Function KolorCzcionki(cell) As Integer
KolorCzcionki = cell.Range("A" & n).Font.ColorIndex
End Function

Sub Wpisz1()
For n = 4 To 171
If KolorCzcionki(Cells()) = 6 Then
Cells(n, 4) = "1"
End If
Next n
End Sub

Rem Makro wpisujące "1" w kolumnie B
Function Wpisz1(cell As Range, kolor As Long)
Application.Volatile
If KolorCzcionki(cell) = kolor Then
WpiszB = "1"
Else
WpiszB = ""
End If
End Function

Rem Makro w powiązaniu z Makro wpisujące "1" w kolumnie A
Function KolorCzcionki(cell As Range) As Long
KolorCzcionki = cell.Font.ColorIndex
End Function

Bartek · ExcelSpec **Pomógł:** 69 razy Posty: 105

Tutaj masz błąd:

Kod:

Function Wpisz1(cell As Range, kolor As Long)
Application.Volatile
If KolorCzcionki(cell) = kolor Then
WpiszB = "1"
Else
WpiszB = ""
End If
End Function

powinno być wszędzie tak samo - albo WpiszB, albo Wpisz1:

Kod:

Function Wpisz1(cell As Range, kolor As Long)
Application.Volatile
If KolorCzcionki(cell) = kolor Then
Wpisz1 = 1
Else
Wpisz1 = ""
End If
End Function

Na początku modułu z makrami dobrze mieć deklarację Option Explicit - zapobiegnie to przypadkowemu użyciu niezadeklarowanych zmiennych. Załączniki dołączaj skompresowany - zip lub rar.

CAVIS · Wysłany: 04-01-2007, 14:57

Witam!

Oczywiście przy przerabianiu makra popełniłam błąd, lecz nadal nie działa.

Przesyłam załącznik.

Zeszyt1-KOLOR CZCIONKI.zip

Pobierz Plik ściągnięto 837 raz(y) 7.73 KB

Bartek · ExcelSpec **Pomógł:** 69 razy Posty: 105

Masz mały bałagan w tym arkuszu, np. takie same nazwy funkcji i procedur. Zamiast tego, proponuje jedno krótkie marko:

Kod:

Sub WpiszJedynki()
Dim Xc As Range

For Each Xc In Intersect(ActiveSheet.UsedRange, Columns(1).Cells)
If Xc.Font.ColorIndex = 3 Then Xc.Offset(0, 3).Value = 1
Next

End Sub

Zmieniając wartośc przy Offset wybierasz kolumnę, tj. np. Offset(0, 1) wpisze jedynki w kolumne B, (0, 2) w kolumnie C itd.

CAVIS · Wysłany: 11-01-2007, 13:12

Witam!

Twoje makro niestety nie działa automatycznie.
I ma błąd: jeżeli zmieni się kolor wpisu z czerwonego na inny kolor, wówczas makro już tego nie kontroluje. Wpisuje 1 gdy zmieni się kolor na czerwony w drugą stronę już nie.

Ten kod makra, który chciałabym aby był bazą do zmiany uruchamiał się jeżeli wpisaliśmy coś do komórki i arkusz się przeliczał lub ręcznie wywołaliśmy przeliczanie arkusza klawiszem F9.

Dlatego moja prośba była skierowana w tę stronę z rozwiązaniem.

Dziekuję.

Bartek · ExcelSpec **Pomógł:** 69 razy Posty: 105