Przypisanie wartości wypełnieniu pola komórki Excel 2007

Question

Witam ponownie!Mam grafik w formie tabelarycznej (graficzny) który wygląda ogólnie tak że w wierszach są dni a w kolumnach godziny przy czym jedna k...

adamas_nt · Accepted Answer

Moja propozycja: odwróć to.
Tzn zastosuj formatowanie warunkowe z wypełnieniem kolorem. Wstawiasz (przez przeciągnięcie) powiedzmy jedynki, które łatwo policzyć =LICZ.JEŻELI(A1:A40;"=1") lub zsumować, wynik można podzielić przez dwa, a komórki "same" sczerwienieją lub zzielenieją, jeśli wstawisz liczbę Np 2, którą łatwo policzyć a wynik podzielić przez cztery itd. Stosując kolor czcionki (formatowanie warunkowe) w tym samym kolorze osiągniesz identyczny efekt z aktualnym...

marek003 · Accepted Answer

Tu nasuwa sie jeszcze pytanie ile masz kolorów? Jeżeli do 3 to ok. jak więcej to kłopot.
Co do reszty zastosuj sugestie kolegi adamas_nt. Ewentualnie zamiast cyfr stosuj litery A, B, C i je zliczaj, dziel przez 2 i i będziesz miał ilość godzin.

marek003 · Accepted Answer

To tylko za pomocą makr.Np. tak:Code: text Expand Select all Copy to clipboard 
Dim kolor(40) As Integer

For y = 1 To 93
   For x = 1 To 24
        For i = 1 To 40
            If Cells(y + 4, x + 2).Interior.ColorIndex = i Then kolor(i) = kolor(i) + 1
        Next i
   Next x
 Next y
 
 For i = 1 To 40
    Cells(i + 4, 28).Interior.ColorIndex = i
    Cells(i + 4, 28).Interior.Pattern = xlSolid
    If kolor(i) <> 0 Then Cells(i + 4, 29) = kolor(i) / 2
 Next iPoniżej działający przykład (trochę trwa liczenie).Po dłuższej chwili pojawi się okno "Gotowe" i tyle.Chciałem dodać klepsydrę aby się kręciła w trakcie liczenia Code: text Expand Select all Copy to clipboardfmMousePointerHourGlass ale nie wiem na chwilę obecną pod jaki obiekt to podpiąć by to ładnie działało.Kod w przykładzie jest "bogatszy w funkcje czyszczące i "okno gotowości"Na marginesie dodam że kolor biały (mimo że go nie widać) jest czym innym niż "brak koloru" (index=0)

adamas_nt · Accepted Answer

Trochę między wódkę a zakąskę, ale wtrącę słówko  marek003 A gdyby tak zostawić kolory na stałe w kolumnie "AB" w Twoim arkuszu? Byłaby co najmniej jedna pętla mniej. Z drugiej strony "wyczyścić" z formatów, kolorów i wartości można poleceniem: Range("AB5:AC44").ClearI jeszcze jedno. Pętla zapisująca do tablicy wykonuje 93x24x40=89280 powtórzeń. Gdyby zastosować For Each komórki w zakresie byłoby ich 93x24=2232 (jeśli dobrze liczę). Czyli z zapisanymi kolorami w kol "AB" Code: text Expand Select all Copy to clipboardFor Each kom In Range("C5:Z97")
    If kom.Interior.ColorIndex > 0 Then
        Cells(kom.Interior.ColorIndex + 4, 29) = Cells(kom.Interior.ColorIndex + 4, 29) + 0.5
    End If
NextI wykonanie obliczeń (tych samych co prawda) w tym przypadku odbywałoby się 40 razy szybciej. Wyłączenie odświeżania (Application.ScreenUpdating) jeszcze ciut przyspieszy wykonywanie kodu.Gdyby "kolorową" pętlę, zgodnie z Twoim zamysłem, umieścić na początku mogłoby to wyglądać takCode: text Expand Select all Copy to clipboardPrivate Sub CommandButton1_Click()
Dim kom As Range, i As Integer
Application.ScreenUpdating = False

Range("AB5:AC44").Clear

For i = 1 To 40
    Cells(i + 4, 28).Interior.ColorIndex = i
    Cells(i + 4, 28).Interior.Pattern = xlSolid
Next i
 
Cells(4, 28) = "Kolor"
Cells(4, 29) = "Ilość godzin"

For Each kom In Range("C5:Z97")
    If kom.Interior.ColorIndex > 0 Then
        Cells(kom.Interior.ColorIndex + 4, 29) = Cells(kom.Interior.ColorIndex + 4, 29) + 0.5
    End If
Next

Application.ScreenUpdating = True
End SubAd. post niżej. Tak z rozpędu mi się "napisało". Oczywiście "="

marek003 · Accepted Answer

Bardzo trafne spostrzeżenie.Skraca to znacznie czas wykonania obliczeń i ta prostota kodu. Tylko (przynajmniej u mnie) wyłączenie i włączenie odświeżania trzeba było podać w ten sposób:Code: text Expand Select all Copy to clipboardApplication.ScreenUpdating = False
...
Application.ScreenUpdating = TrueBo inaczej wyskakiwał błąd "Invalid qualifier".Poniżej przykład z o wiele szybszym w działaniu makrem kolegi adamasa

adamas_nt · Accepted Answer

I jeszcze drobna poprawka dla E2007 na początku makra, aby sprawdzać wszystkie kolory z palety Code: text Expand Select all Copy to clipboardRange("AB5:AC60").Clear

For i = 1 To 56

marek003 · Accepted Answer

Zasugerowałem się przyciskiem "kolor wypełnienia" w Excel2003. Jest tam tylko 40 kolorów. Sądziłem że sa po kolei ale jak przed chwila sprawdziłem - myliłem się. W zestawie 40 nie ma np ciemnego żółtego co będzie wpływać na ewentualne obliczenia.
Więc we wszystkich makrach powyżej należy poprawić 40 na 56.
(W przypadku pierwszego makra wydłuży to jeszcze obliczenia bo "kolorowa" pętla by przechodziła 56 razy zamiast 40 czyli 93x24x56=124992 powtórzenia więc sugeruje poprawiać drugie rozwiązanie.

marek003 · Accepted Answer

Najlepiej by było gdybyś w załączniku podpiął twój przykładowy arkusz.Wtedy łatwiej będzie znaleźć ten błąd.I jeszcze jedno - na chwilę obecną to makro sprawdza wszystkie kolory z palety więc nie trzeba nic definiować.Wklej ten kod między Private Sub ...() a End SubCode: text Expand Select all Copy to clipboardDim kom As Range, i As Integer
Application.ScreenUpdating = False


Range("AB5:AC60").Clear

For i = 1 To 56
    Cells(i + 4, 28).Interior.ColorIndex = i
    Cells(i + 4, 28).Interior.Pattern = xlSolid
Next i
  
Cells(4, 28) = "Kolor"
Cells(4, 29) = "Ilość godzin"

For Each kom In Range("C5:Z97")
    If kom.Interior.ColorIndex > 0 Then
        Cells(kom.Interior.ColorIndex + 4, 29) = Cells(kom.Interior.ColorIndex + 4, 29) + 0.5
    End If
Next

Application.ScreenUpdating = Truei powinno działać ewentualnie zamieść załącznik (jak duży to spakuj i wyłącz prowizję)Teraz sobie uświadomiłem że twoja tabela może być całkiem w innym miejscu arkusza a makro jest pod mój przykład więc koniecznie zamieść załącznik w excelu z twoją przykładową tabelą lub popraw odwołania i liczby w powyższym kodzie - dostosuj do twojej tabeli. Dodano po 58 [minuty]: A dodając jeszcze niewielką pętle pokażą się tylko kolory które uwzględniłeś w tabeli.Code: text Expand Select all Copy to clipboard
Sub Kolory()

Dim kom As Range, i As Integer
Application.ScreenUpdating = False

nazwa = ActiveSheet.Name
With Sheets(nazwa)

.Range("AE5:AF60").Clear

For i = 1 To 56
    .Cells(i + 4, 33).Interior.ColorIndex = i
    .Cells(i + 4, 33).Interior.Pattern = xlSolid
Next i
  
For Each kom In .Range("C5:Z97")
    If kom.Interior.ColorIndex > 0 Then
        .Cells(kom.Interior.ColorIndex + 4, 33) = .Cells(kom.Interior.ColorIndex + 4, 33) + 0.5
    End If
Next

.Cells(4, 31) = "Kolor"
.Cells(4, 32) = "Ilość godzin"

For i = 1 To 56
    If .Cells(i + 4, 33).Value <> "" Then
        x = x + 1
       .Cells(x + 4, 31).Interior.ColorIndex = .Cells(i + 4, 33).Interior.ColorIndex
       .Cells(x + 4, 31).Interior.Pattern = xlSolid
       .Cells(x + 4, 32).Value = .Cells(i + 4, 33).Value
    End If
Next i

Range("AG5:AG60").Clear

End With
Application.ScreenUpdating = True

End Sub

marek003 · Accepted Answer

Co do przycisku wywołujacego makro.
Jeżeli masz więcej arkuszy i będzie to w nich wykorzystywane to kod umieść w module.

Menu - Widok - paski narzędzi - Visual Basic.
Na tym pasku wciśnij Edytor Visual Basic.
Otworzy ci się edytor makr.
Po lewej stronie będzie okienko "project -VBA project" .
Znajdź pogrubioną nazwę twojego skoroszytu i prawokliknij na nią.
Z menu podręcznego wybierz insert - module.
Pojawi się pod pogrubiona nazwą skoroszytu i nazwami arkuszy w tym skoroszycie nazwa Module1 (jak to będzie pierwszy moduł).
Dwukrotnie kliknij w Module1.
W biały ekran wklej mój cały ostatni kod (przed chwilą go poprawiłem).
Przejdź do arkusza excela.
Menu widok - paski narzędzi - formularze.
Naciśnij na tym menu przycisk i narysuj go w miejscu gdzie ma być.
Pojawi się okno przypisania makra wskaż "kolory" daj OK i już.

Z tym że mój kod jest pod ustawienia mojej tabeli. W twoim przypadku zapewne trzeba zmienić adresy i numery więc warto by było jednak dodać załącznik.

Jeżeli chcesz poznać działanie tego makra można wytłumaczyć krok po kroku działanie każdej linii kodu.

marek003 · Accepted Answer

W załączniku twój przykład.
Rzeczywiście przy umieszczeniu kodu w module trzeba było troszkę jeszcze poprawić kod (co uczyniłem powyżej). [Ukierunkować na odpowiedni arkusz]

Co do tabel:
Proponuje najpierw wcisnąć przelicz a potem opisywać kolory. Chyba że kolory będą zawsze przypisane temu samemu odbiorcy.
Wtedy przydałby się arkusz ze słownikiem.

Kolejna rzecz to to że formuła obliczeniowa zajmuje przestrzeń w arkuszu od AE5 do AF60. W tych komórkach nie możesz nic wpisywać bo zostanie to wykasowane. Nie możesz też tych komórek scalać bo nastąpi błąd formuły.

I ostatnia rzecz twoje tabele powinny być identyczne w każdym miesiącu (bez przesunięć wierszy lub kolumn).

adamas_nt · Accepted Answer

Pokazywanie tylko użytych kolorów nasunęło mi pewien pomysł...
W załączniku (jeszcze) inna wersja rozwiązania, oparta na zwykłym wyszukiwaniu komórek o zgodnym kolorze.

Edit: Sprawdziłem (Timerem) szybkość działania. Przegrywam z rozwiązaniem kolegi marek003 w stosunku 0,25 do 0,87 sek.

marek003 · Accepted Answer

adamas_nt
Jak analizuje twoje kody to widzę że bardzo daleko mi jeszcze do pisania makr.
Dzięki twojej wiedzy można było skrócić czas obliczeń (przynajmniej za pierwszym razem o parę sekund

a nie milisekund,a drugie rozwiązanie też jest ciekawe)
[Do Autora: Koledze Adamas_nt'owi należy się wielokrotne pomógł- a może nawet więcej]

Ja już tylko skromnie dołożyłem jeszcze arkusz ze słownikiem i jeden wiersz do kodu kolegi adamas_nt by makro wpisywało również nazwy firm.

  Cells(i, "AG") = Sheets("Słownik").Cells(kom.Interior.ColorIndex + 1, 2).Value

(Na marginesie kolejność kolorów w słowniku ma wielkie znaczenie i nie należy jej zmieniać najwyżej nie wypełniać nazwy firmy przy danym kolorze. Związane jest to z tym że makro w arkuszu Słownik nie szuka po kolorze. Kolory ułożone są po kolei wg indeksów. Nie wiedziałem jak bez przełączania się między arkuszami, co zaciemniło by główny kod, wykorzystać funkcję find dla koloru w arkuszu Słownik)

marek003 · Accepted Answer

A tu "stara" (niby szybsza) wersja ze słownikiem.

marek003 · Accepted Answer

Poniżej załączam ostateczną wersję ładnie poprawioną (w sobotni poranek ) przez kolegę adamas_nt Przedstawia czytelnie poszczególne kolory i firmy. Tak jak chciał to przedstawiać autor (załącznik autora z plikiem).Przedstawiam przesłany do mnie kod makra a poniżej plik z tym makrem.Code: text Expand Select all Copy to clipboardSub Kolory()

Dim kom As Range, i As Integer, x As Integer
Application.ScreenUpdating = False

Range("AE5:AE230").Clear
Range("AF5:AG230").ClearContents

For i = 1 To 56
    Cells(i + 4, 34).Interior.ColorIndex = i
Next i
  
For Each kom In Range("C5:Z97")
    If kom.Interior.ColorIndex > 0 Then
        Cells(kom.Interior.ColorIndex + 4, 34) = Cells(kom.Interior.ColorIndex + 4, 34) + 0.5
    End If
Next

Cells(4, 31) = "Kolor"
Cells(4, 32) = "Ilość godzin"
Cells(4, 33) = "Firma"

For i = 1 To 56
    If Cells(i + 4, 34).Value <> "" Then
        x = x + 4
       Cells(x + 4, 31).Interior.ColorIndex = Cells(i + 4, 34).Interior.ColorIndex
       Cells(x + 5, 31).Interior.ColorIndex = Cells(i + 4, 34).Interior.ColorIndex
       Cells(x + 4, 32).Value = Cells(i + 4, 34).Value
       Cells(x + 4, 33).Value = Sheets("Słownik").Cells(Cells(x + 4, 31).Interior.ColorIndex + 1, 2).Value
    End If
Next i

Range("AH5:AH60").Clear

Application.ScreenUpdating = True

End Sub

epi78 · Answer

Hmmm może żeby bardziej zobrazować mój problem wkleję prt sc żebyście mogli zobaczyć jak to wygląda.

Jak widać w kolumnie pierwszej są dni miesiąca a w każdym z nich są trzy sale. Ten grafik służy głównie do graficznego zobrazowania obłożenia sal, kolorów jest znacznie więcej niż 3 a każdy mówi mi na jakich zasadach przygotować salę. Dodatkowo w każdej lini naniesionej w wierszu (jakiś kolor) dopisuję różne informacje potrzebne dla mnie lub pracownika. Chciałem jednak rozbudować funkcjonalność tej tabeli o funkcje liczące i statystyczne ale wyjściem do tego jest nadanie wartości poszczególnym kolorom. Pomysł z wpisywaniem cyfr w każdą komórkę choć skuteczny i stosunkowo prosty to jednak utrudni prowadzenie tego grafiku oraz zaburzy jego i tak nie najlepszą czytelność. Nie wiecie czy przypadkiem jest inny sposób?
Proszę o pomoc i pozdrawiam

epi78 · Answer

Powiem szczerze ze jestem pod wrażeniem waszej wiedzy... makra w zasadzie są mi kompletnie obce i w zasadzie to nie wiem jak to ugryźć. Ogólnie to znalazłem funkcję w exelu dot makr ale po skopiowaniu podanej przez Was formuły wyskakuje mi jakiś błąd. nie wiem również jak mam to przenieść na moją tabelę i zdefiniować kolory bo przecież trzeba zidentyfikować poszczególne z nich żeby komp wiedział co liczyć...moglibyście dokładniej wytłumaczyć jak mam ugryźć tą formułę? Z góry dzięki

epi78 · Answer

Dodam cały plik z tabelą, bo to faktycznie najlepsze rozwiązanie...
Ogólnie to lubię dochodzić sam do takich rzeczy jednak mam straswznie dużo na głowie i nie mam totalnie czasu żeby próbować to rozgryźć...
Musiałem jednak zapisać jako dokument excela z 2003 bo z excela 2007 rozszerzenie jest nieakceptowane przez elektrodę. Mam nadzieję ze przez to nie będzie problemu... dodałem jeszcze ewentualnie w PDFie
Spróbuję jednak postąpić wg instrukcji marek003

pozdro

epi78 · Answer

Panowie jesteście niesamowici... Wiedziałem że Excel jest bardzo rozbudowanym programem ale wasze makra i propozycje przeszły moje oczekiwania... Jak tylko złapię chwilkę biorę sie za testy:)
Gorąco pozdrawiam i punkty przyznaję rękami i nogami:) Dam znać jak mi to będzie działać... pozdrawiam gorąco!

epi78 · Answer

Wszystko działa pięknie - bardzo dzięuję za pomoc.. mam nadzieję że nie tylko mnie się te instrukcję przydadzą...Szacuneczek