Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 70146 Skopiuj do schowka Kolorowanie komórek wg schematu - VBA
Autor Wiadomość
ws1948 
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 10 razy
Posty: 343
Wysłany: 14-02-2021, 21:20   Kolorowanie komórek wg schematu - VBA

Witam,
zacząłem zgłębiać temat tablic. Niestety okazało się, że moja wiedza zaczerpnięta z lektur i przeglądania forum nie wystarczyła do rozwiązania problemu, jak pokolorować komórki wg określonego schematu używając VBA.
W załączniku umieściłem dwie tabele: wybór jednej z nich zależy od losowania (1 lub 2).

Prosiłbym, aby rozwiązaniem było makro. Najlepiej zdarzeniowe.
Kod, który wpisałem powstał na podstawie przeczytanej lektury, nie wiem czy jest zgodny z praktyką.

Forumowicze, których zainteresuje temat i zechcą odpowiedzieć, bardzo proszę o szczegółowy komentarz, gdyż chciałbym przy okazji podszkolić się w tym temacie.

Tablice umieszczone w kodzie powstały na podstawie tabel w kolumnach B:I
Zestaw 2 powstał z zestaw 1 zamieniając kol A z B oraz C z D.
Niżej zamieszczam swoje "dokonania"

Kod:
Option Explicit
Option Base 1
Sub Kolory()

Dim zestaw As Byte
Dim C As Variant, B As Variant, N As Variant, Z As Variant
Dim zest1 As String, zest2 As String

zest1 = Array("Z", "C", "B", "N" \ "C", "B", "N", "Z" \ _
              "Z", "B", "N", "Z" \ "N", "Z", "C", "B" \ _
              "C", "B", "N", "Z" \ "C", "B", "N", "Z" \ _
              "B", "N", "Z", "C" \ "B", "C", "Z", "N" \ _
              "C", "Z", "N", "B" \ "B", "C", "Z", "N" \ _
              "N", "B", "C", "Z" \ "Z", "N", "B", "C" \ _
              "N", "Z", "C", "B" \ "Z", "C", "B", "N" \ _
              "C", "Z", "N", "B")

zest2 = Array("C", "Z", "N", "B" \ "B", "C", "Z", "N" \ _
              "N", "Z", "C", "B" \ "Z", "N", "B", "C" \ _
              "B", "C", "Z", "N" \ "B", "C", "Z", "N" \ _
              "N", "B", "C", "Z" \ "C", "B", "N", "Z" \ _
              "Z", "C", "B", "N" \ "Z", "C", "B", "N" \ _
              "C", "B", "N", "Z" \ "B", "N", "Z", "C" \ _
              "Z", "N", "B", "C" \ "C", "Z", "N", "B" \ _
              "Z", "C", "B", "N")
End Sub


kolorowanie.xlsm
Pobierz Plik ściągnięto 6 raz(y) 20.53 KB

ID posta: 400399 Skopiuj do schowka
 
 
ąćęłńóś
Excel Expert


Pomógł: 320 razy
Posty: 1571
Wysłany: 14-02-2021, 22:37   

No dobrze, ale ten "schemat vba", to ma być "zakodowany" w module vba (w kodzie), czy też ma pochodzić z komórek (z literkami) z tych tabelek do kolorowanka ?

... hmm ... "Z" to chyba "zielony", nie żółty (?) ...
ID posta: 400404 Skopiuj do schowka
 
 
ws1948 
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 10 razy
Posty: 343
Wysłany: 14-02-2021, 22:48   

Schemat najlepiej gdyby był w kodzie,dlatego umieściłem tablice: zest1 i zes2.
Litera "Z" to "Ż" bez kropki.

ws
ID posta: 400405 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 2016
Pomógł: 2039 razy
Posty: 6444

Wysłany: 15-02-2021, 01:24   

Ten początek kodu zrobiłeś dość niefortunnie. Tablice definiowane przez funkcję Array są zawsze tablicami jednowymiarowymi. Separatorem jest zawsze tylko przecinek.
Stałe tablicowe znane z Excela (dwuwymiarowe) można adaptować do VBA za pomocą funkcji Evaluate, ale w tym przypadku trzeba stosować separatory na modłę amerykańską (przecinek i średnik), ale ten sposób w przypadku tekstów 1-literowych nie jest zbyt wygodny (za dużo cudzysłowów). Lepiej pojedyncze litery połączyć w ciągi tekstowe i potem odczytywać z nich kolejne znaki programowo.
Moja propozycja poniżej. Wykorzystuje funkcje Array, ale w inny sposób.
Jest to powiązany zestaw procedur i funkcji. Procedura jest zwykła, nie zdarzeniowa, bo nie bardzo wiadomo na jakie zdarzenie miałaby reagować. To sobie najwyżej przerobisz.

Kod:
Sub Kolory()
   Dim Zestaw1, Zestaw2
   Zestaw1 = Array("ZCZNCCBBCBNZNZC", "CBNZBBNCZCBNZCZ", "BNBCNNZZNZCBCBN", "NZCBZZCNBNZCBNB")
   Zestaw2 = Array("CBNZBBNCZCBNZCZ", "ZCZNCCBBCBNZNZC", "NZCBZZCNBNZCBNB", "BNBCNNZZNZCBCBN")
         
    ' wyświetlenie zestawu 1 w zakresie C6:F20
   Pokaz_Zestaw Zestaw1, Range("C6")
     
    ' wyświetlenie zestawu 2 w zakresie I6:L20
   Pokaz_Zestaw Zestaw2, Range("I6")
   
End Sub

Sub Pokaz_Zestaw(wzor, miejsce As Range)
   Dim kol As Long, wie As Long
   With miejsce        'wystarczy początek zakresu
      For kol = 1 To 4
         For wie = 1 To 15
            .Cells(wie, kol).Interior.Color = _
                   Application.Run(Mid(wzor(kol - 1), wie, 1) & "_")
                    ' elementy tablicy są numerowane od 0
      Next wie, kol
   End With
End Sub

Function Z_() As Long
   Z_ = RGB(255, 255, 0)   ' żółty
End Function
Function C_() As Long
   C_ = RGB(255, 80, 80)   ' czerwony
End Function
Function B_() As Long
   B_ = RGB(255, 255, 255) ' biały
End Function
Function N_() As Long
   N_ = RGB(179, 198, 231) ' niebieski
End Function

W głównej procedurze Kolory są zdefiniowane wzorce wypełnienia w postaci tablic Array. Każda tablica jest 4-elementowa, każdy element to jedna kolumna. Kolumna jest tekstem złożonym z 15 liter symbolizujących kolory.

Zestawy są wyświetlane za pomocą procedury Pokaz_zestaw z dwoma argumentami: pierwszy oznacza tablicę wzorów, drugi - adres początku zakresu, gdzie mają być wyniki.

Wyświetlanie odbywa się w podwójnej pętli po kolumnach i wierszach, indywidualnie dla każdej komórki.
Wzory kolorów zapisałem jako kolory RGB w postaci funkcji bezargumentowych (a nie zmiennych) ze względu na sposób wywołania. Nazwa każdej funkcji składa się z litery oznaczającej kolor i znaku podkreślenia. Znak podkreślenia dodałem, bo jeden z kolorów oznaczono literą C, a funkcji o takiej nazwie nie można zdefiniować.

Funkcje są wywoływane pośrednio za pomocą metody Run. Wywołanie ma postać:
Kod:
Application.Run(Mid(wzor(kol - 1), wie, 1) & "_")

Źródłem danych jest tablica wzor. Składa się ona z 4 elementów (odpowiadających kolumnom), numerowanych od 0 do 3 (tablica Array jest standardowo indeksowana od 0). Każdy element tej tablicy jest tekstem 15-znakowym. Tekst ten jest rozdzielany na poszczególne litery za pomocą funkcji Mid, do litery dopisujemy podkreślenie i jako tekst przekazujemy do metody Run. Wynik - wartość koloru jest przypisywana do właściwości Interior.Color odpowiedniej komórki.

kolorowanie.xlsm
Pobierz Plik ściągnięto 2 raz(y) 28.56 KB

ID posta: 400408 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3100 razy
Posty: 10274
Wysłany: 15-02-2021, 02:38   

Pewnie co programista, to by dał inne rozwiązanie. :-) Więc będzie inaczej.
Tylko dla jednego zestawu, co można sobie rozbudować.
Kod:
Option Explicit

Enum MojeKolory
  Bialy = 16777215 'RGB(255, 255, 255)
  Czerwony = 5263615 'RGB(255, 80, 80)
  Niebieski = 15189683 'RGB(179, 198, 231)
  Zolty = 65535 'RGB(255, 255, 0)
End Enum

Sub Kolory1()
    Dim zest1 As Variant
    Dim vTmp        As Variant
    Dim vTmp1       As Variant
    Dim lCol        As Long
    Dim w           As Long
    Dim k           As Long

    'zapis kolorów tablicy dwuwymiarowej w tablicy jednowymiarowej
    'znak "\" oznacza przejście do nowego wiersza
    'znak "," przejście do następnej kolumny
    'Ten Split podzieli na wiersze
    vTmp = Split("Z,C,B,N\C,B,N,Z\Z,B,N,Z\N,Z,C,B\C,B,N,Z\C,B,N,Z\B,N,Z,C\" & _
                 "B,C,Z,N\C,Z,N,B\B,C,Z,N\N,B,C,Z\Z,N,B,C\N,Z,C,B\Z,C,B,N\C,Z,N,B", "\")
   
    'dowiedz się ile kolumn będzie miała tablica wynikowa (zest1)
    'na podstawie jednego elementu pierwszej tablicy pomocniczej
    lCol = UBound(Split(vTmp(0), ","))

    'zadeklaruj tablicę wynikową dwuwymiarową
    ReDim zest1(0 To UBound(vTmp), 0 To lCol)

    'przepisz dane z tablic pomocniczych do tablicy wynikowej
    For w = 0 To UBound(vTmp)
        'podziel badany element na "kolumny"
        vTmp1 = Split(vTmp(w), ",")
        For k = 0 To lCol
            zest1(w, k) = vTmp1(k)
        Next k
    Next w

    'tutaj mamy już wypełnioną tablicę zest1
   
    'wypełniamy zakres kolorami
    With Range("C6")
        For w = 0 To UBound(vTmp)
            For k = 0 To lCol
                .Offset(w, k).Interior.Color = ZnakNaKolor(CStr(zest1(w, k)))
            Next k
        Next w
    End With

End Sub

Sub Kolory2()
    Dim vTmp       As Variant
    Dim vTmp1       As Variant
    Dim lCol        As Long
    Dim w           As Long
    Dim k           As Long

    vTmp = Split("Z,C,B,N\C,B,N,Z\Z,B,N,Z\N,Z,C,B\C,B,N,Z\C,B,N,Z\B,N,Z,C\" & _
                 "B,C,Z,N\C,Z,N,B\B,C,Z,N\N,B,C,Z\Z,N,B,C\N,Z,C,B\Z,C,B,N\C,Z,N,B", "\")
   
    lCol = UBound(Split(vTmp(0), ","))

    With Range("C6")
        For w = 0 To UBound(vTmp)
            vTmp1 = Split(vTmp(w), ",")
            For k = 0 To lCol
                .Offset(w, k).Interior.Color = ZnakNaKolor(CStr(vTmp1(k)))
            Next k
        Next w
    End With

End Sub

Function ZnakNaKolor(Znak As String) As Long
  Select Case UCase(Znak)
    Case "B"
        ZnakNaKolor = Bialy
    Case "C"
        ZnakNaKolor = Czerwony
    Case "N"
        ZnakNaKolor = Niebieski
    Case "Z"
        ZnakNaKolor = Zolty
  End Select
End Function
Procedura Kolory1 to pełna wersja (bo wreszcie mamy ćwiczyć tablice :-) ). Kolory2 - wersja skrócona, gdyż tablica wynikowa nie jest potrzebna.

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 400409 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 2016
Pomógł: 2039 razy
Posty: 6444

Wysłany: 15-02-2021, 10:31   

To ode mnie jeszcze jeden wariant rozwiązania. Początek i idea taka jak w pierwszej propozycji. Zmiana dotyczy sposobu gromadzenia informacji o tym jaki kolor gdzie wyświetlić.
Tym razem dla czterech kolorów są tworzone cztery zakresy złożone obejmujące komórki o takim samym kolorze, a potem te kolory są nadawane hurtem.
Kod:
Sub Pokaz_Zestaw(wzor, miejsce As Range)   ' miejsce = początek zakresu
   Dim kom As Range, kol As Long, wie As Long
   Dim zolte As Range, czerw As Range, biale As Range, nieb As Range
   For Each kom In miejsce.Resize(15, 4)
      kol = kol Mod 4 + 1
      If kol = 1 Then wie = wie + 1
      Select Case Mid(wzor(kol - 1), wie, 1)
         Case "Z": Dodaj kom, zolte
         Case "C": Dodaj kom, czerw
         Case "B": Dodaj kom, biale
         Case "N": Dodaj kom, nieb
      End Select
   Next kom
   zolte.Interior.Color = RGB(255, 255, 0)   ' żółty
   czerw.Interior.Color = RGB(255, 80, 80)   ' czerwony
   biale.Interior.Color = RGB(255, 255, 255) ' biały
   nieb.Interior.Color = RGB(179, 198, 231)  ' niebieski
End Sub

Sub Dodaj(co As Range, grupa As Range)
   If grupa Is Nothing Then Set grupa = co
   Set grupa = Union(grupa, co)
End Sub


kolorowanie2.xlsm
Pobierz Plik ściągnięto 3 raz(y) 28.57 KB

ID posta: 400417 Skopiuj do schowka
 
 
ws1948 
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 10 razy
Posty: 343
Wysłany: 15-02-2021, 11:18   

Witam,
o tym który zestaw będzie wykorzystywany decydować będzie wpis np. w komórce C2 cyfry 1 lub 2. Dlatego myślałem o wywołaniu zdarzeniowym.
Czy taka wersja wywołania jest prawidłowa?
Kod:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("C2")) Is Nothing Then Kolory
    End If
End Sub

W arkuszu w którym chciałbym wykorzystać to makro mam już inne makro. Czy wystarczy wkleić po istniejącym to makro ?

Pozdrawiam

ws
ID posta: 400422 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 2016
Pomógł: 2039 razy
Posty: 6444

Wysłany: 15-02-2021, 12:00   

Zamiast pytać o wszystko trzeba spróbować. Komputera nie zepsujesz, a jeśli nie będzie działać, to trzeba uruchamiać program krokowo i śledzić jak wykonują się kolejne instrukcje.
Co do zasady - procedury i funkcje wykonawcze umieszcza się z reguły w modułach uniwersalnych (Module), a z modułu arkusza tylko się je wywołuje. To zapewnia większą elastyczność.
Jeśli chodzi o Twoje makro zdarzeniowe, to nie powinieneś zawsze stosować schematów. Jeśli w tym przypadku chodzi Ci tylko o jedną komórkę można zastosować krótszy warunek:
Kod:
If Target.Address = "$C$2" Then ...
pamiętając, że właściwość Address zwraca adres w formie tekstu i domyślnie z dolarami. To równocześnie weryfikuje i jedną komórkę i jej adres.
Wywołanie makra kolory bez argumentów nie spełni swojego zadania, bo makro nie będzie wiedziało ani jaka liczba jest w komórce C2, ani gdzie ma wyświetlić te kolory.
Musisz napisać sobie makro z argumentami, żeby przekazać te informacje i wykorzystać je.
Pamiętaj, że wywołując w VBA makro z argumentami, tych argumentów nie umieszczamy w nawiasach, tylko po spacji.
W module uniwersalnym możesz umieszczać dowolne makra i funkcje. One sobie nie przeszkadzają. Natomiast w module arkusza lub skoroszytu, gdzie masz makra obsługujące zdarzenia, możesz mieć tylko jedno makro do obsługi jednego zdarzenia, więc takie makra należy łączyć.
ID posta: 400426 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 15-02-2021, 12:29   

Też dodam swoją propozycję.
Do modułu arkusza 'Zestaw' skopiuj kod.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [h2]) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        kolory Target.Value
        .EnableEvents = True
    End With
End Sub
Do modułu normalnego VBA poniższy kod.
Kod:
Option Explicit

Sub kolory(wyb As Integer)
    Dim a(), v, kol
    Dim rng As Range
    Dim i As Integer, ii As Integer
   
    ReDim kol(1 To 4, 1 To 2)
    kol(1, 1) = "Z":        kol(1, 2) = 65535               'żółty         -   65535
    kol(2, 1) = "C":        kol(2, 2) = 5263615           'czerwony  -   5263615
    kol(3, 1) = "B":        kol(3, 2) = 16777215         'biały          -   16777215
    kol(4, 1) = "N":        kol(4, 2) = 15189684         ' niebieski     - 15189684
    With Sheets("Zestaw")
        With .[b5].CurrentRegion.Offset(2, 1)
            If wyb = 1 Then
                a = .Resize(.Rows.Count - 2, .Columns.Count - 1).Value
            Else
                a = .Offset(, 6).Resize(.Rows.Count - 2, .Columns.Count - 1).Value
            End If
            Set rng = Range("P6").Resize(UBound(a), UBound(a, 2))
            rng.Interior.Color = xlNone
            For i = 1 To UBound(a)
                For ii = 1 To UBound(a, 2)
                    v = Application.Match(Trim$(a(i, ii)), Application.Index(kol, 0, 1), 0)
                    rng.Cells(i, ii).Interior.Color = kol(v, 2)
                Next
            Next
        End With
        .[o4].Value = "Zestaw " & wyb
    End With
End Sub


kolorowanie_kuma.xlsm
Pobierz Plik ściągnięto 2 raz(y) 30.69 KB

_________________
Pozdrawiam.
ID posta: 400432 Skopiuj do schowka
 
 
ws1948 
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 10 razy
Posty: 343
Wysłany: 15-02-2021, 17:33   

Witam,
kuma twoja propozycja oparta na tabelach jest interesująca. Mogę utworzyć tabelę pomocniczą, która będzie przybierała wartości z jednej lub drugiej tabeli w zależności od wyboru,
Pojawił się jednak problem. W arkuszu w którym chciałbym je wykorzystać mam już makro wywoływane zdarzeniowo. Poniżej zamieszczam jego kod.

Wywołanie:
Kod:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("E19,C2,T101")) Is Nothing Then Liga
    End If
End Sub


oraz samo makro

Kod:
Sub Liga()
    'otrzymany od mkkk23, ID posta: 234746  wysłany: 24-08-2014
    'uzupełniony przez Tajan 03-10-2014  ID posta: 238515
   
    Const Adres1 As String = "C2|B25|B29|B30|B31|B32|B33|B34|B35|B36|B37|B38|B39|B40|" & _
                             "B41|B42|B43|B44|B45|B46|B47|B48|B49|B50|B51|B52|B53|C6|C7|" & _
                             "C8|C9|C10|C11|C12|C13|C14|C15|C16|C17|C19|C20"
   
    Const Adres2 As String = "B3:C4|B24:F26|B29|B30|B31|B32|B33|B34|B35|B36|B37|B38|B39|B40|" & _
                             "B41|B42|B43|B44|B45|B46|B47|B48|B49|B50|B51|B52|B53|B6|B7|B8|B9|" & _
                             "B10|B11|B12|B13|B14|B15|B16|B17|D19|B20:C20"
   
    Dim xlWks As Excel.Worksheet
    Dim strJPGPath As String
    Dim Shp As Shape
    Dim strJPGName As String
    Dim strJPGFullName As String
    Dim sinOffset As Byte
    Dim i As Byte
    Dim rng1 As Range, rng2 As Range
   
    Application.ScreenUpdating = False
   
    With ThisWorkbook
        Set xlWks = .Worksheets("Liga")
        strJPGPath = .Path & "\"
    End With
   
    For i = 0 To 40
       
        sinOffset = 2
        'If i = 2 Or i = 3 Then sinOffset = 2 Else sinOffset = 1
        With xlWks
           
            Set rng1 = .Range(Split(Adres1, "|")(i))
            Set rng2 = .Range(Split(Adres2, "|")(i))
           
            strJPGName = rng1.Value & ".jpg"
            strJPGFullName = strJPGPath & strJPGName
           
            For Each Shp In .Shapes
                With Shp
                    If .Type = msoPicture Then
                        If Not Intersect(.TopLeftCell, rng2) Is Nothing Then
                            .Delete
                            Exit For
                        End If
                    End If
                End With
            Next Shp
           
            If Not rng1.Value = "" Then
               
                If Dir(strJPGFullName) = vbNullString Then _
                strJPGFullName = strJPGPath & "brak obrazka.jpg"
               
                Set Shp = .Shapes.AddPicture(Filename:=strJPGFullName, _
                                             LinkToFile:=msoFalse, _
                                             SaveWithDocument:=msoTrue, _
                                             Left:=rng2.Left + sinOffset, _
                                             Top:=rng2.Top + sinOffset, _
                                             Width:=rng2.Width - 2 * sinOffset, _
                                             Height:=rng2.Height - 2 * sinOffset)
               
                With Shp
                    .Placement = xlMoveAndSize
                End With
               
            End If
           
        End With
       
    Next i
   
    Application.ScreenUpdating = True
   
    Set xlWks = Nothing
    Set Shp = Nothing
   
End Sub

Służy ono do wstawiania obrazków. Nie wstawiam pliku poglądowego, gdyż oryginalny jest zbyt duży, a próba jego odchudzenia skończyła się moją porażką.

Maciej Gonet napisał "W module uniwersalnym możesz umieszczać dowolne makra i funkcje. One sobie nie przeszkadzają. Natomiast w module arkusza lub skoroszytu, gdzie masz makra obsługujące zdarzenia, możesz mieć tylko jedno makro do obsługi jednego zdarzenia, więc takie makra należy łączyć.".
Pojawia się kolejny problem, gdyż oprócz wklejenia, potrzebna będzie jego synchronizacja i dopasowanie wywołania.

ws
ID posta: 400459 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 15-02-2021, 18:30   

Spróbuj połączyć makra zdarzeniowe w ten sposób. Powinny działać prawidłowo.
Proponuję przenieś kod procedury 'Liga' do modułu normalnego, a nie zostawiać w module arkusza.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
            If Not Intersect(Target, [h2]) Is Nothing Then
                kolory Target.Value
            Else
                If Not Intersect(Target, Range("E19,C2,T101")) Is Nothing Then Liga
            End If
            .EnableEvents = True
        End With
    End If
End Sub
_________________
Pozdrawiam.
ID posta: 400465 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 2016
Pomógł: 2039 razy
Posty: 6444

Wysłany: 15-02-2021, 18:35   

Nie mam czasu na szczegółową analizę Twoich kodów, ale jeśli one uaktywniają się po zmianie różnych komórek, to nie ma problemu, bo w nagłówkach określasz która część kodu kiedy ma się wykonać.
A jeśli reagują na zmianę w tej samej komórce, to musisz zdecydować w jakiej kolejności mają się wykonać i w tej kolejności umieścić je w kodzie.
ID posta: 400467 Skopiuj do schowka
 
 
ws1948 
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 10 razy
Posty: 343
Wysłany: 16-02-2021, 11:58   

Witam,
z przedstawionych propozycji najbardziej zainteresowała mnie propozycja kuma. Prosiłbym o modyfikację do sytuacji jaką przedstawiłem w załączniku.

Pozdrawiam

ws

Kolory_modyf.xlsm
Pobierz Plik ściągnięto 4 raz(y) 35.85 KB

ID posta: 400511 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 16-02-2021, 14:19   

Jak Ci się "wywali" program to najprawdopodobniej nie będą aktywne zdarzenia. Aby je aktywować uruchom procedurę 'AktywujZdarzenia - na końcu w 'Module1'.

Kolory_modyf_kuma.xlsm
Pobierz Plik ściągnięto 5 raz(y) 32.25 KB

_________________
Pozdrawiam.
ID posta: 400519 Skopiuj do schowka
 
 
ws1948 
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 10 razy
Posty: 343
Wysłany: 17-02-2021, 19:39   

Witam,
podczas uruchamiania makra kolory() pojawia się informacja o błędzie : Run-time error 13 Type mismatch w kodzie na żółto zaznaczona jest linia:
Kod:
rng.Cells(i, ii).Interior.Color = kol(v, 2)


Zamieszczam początek makra Liga()
Kod:
Dim xlWks As Excel.Worksheet
    Dim strJPGPath As String
    Dim Shp As Shape
    Dim strJPGName As String
    Dim strJPGFullName As String
    Dim sinOffset As Byte
    Dim i As Byte
    Dim rng1 As Range, rng2 As Range

makro kolory()
Kod:
 Sub kolory(wyb As Integer)                           'autor kuma  ID posta: 400432

    Dim a(), v, kol
    Dim rng As Range
    Dim i As Integer, ii As Integer
   
    ReDim kol(1 To 4, 1 To 2)
    kol(1, 1) = "Z":        kol(1, 2) = 65535                      'żółty  -   65535
    kol(2, 1) = "C":        kol(2, 2) = 5263615                 'czerwony  -   5263615
    kol(3, 1) = "B":        kol(3, 2) = 16777215                   'biały  -   16777215
    kol(4, 1) = "N":        kol(4, 2) = 15189684              ' niebieski  -   15189684
     With Sheets("Liga")
        With .[AW59].CurrentRegion.Offset(2, 1)
            a = .Resize(.Rows.Count - 2, .Columns.Count - 1).Value
            Set rng = Range("K60").Resize(UBound(a), UBound(a, 2))
            rng.Interior.Color = xlNone
            For i = 1 To UBound(a)
                For ii = 1 To UBound(a, 2)
                    v = Application.Match(Trim$(a(i, ii)), Application.index(kol, 0, 1), 0)
                    rng.Cells(i, ii).Interior.Color = kol(v, 2)
                Next
            Next
        End With
        .[AX57].Value = "Zestaw " & wyb
       ' .[o4].Value = "Zestaw " & wyb
     End With
    Set rng = Nothing
  End Sub

Proszę bardzo o pomoc w usunięciu błędu, Sama SUB Liga() działa bezbłędnie. Całe makro Liga znajduje się w poście wyżej

Pozdrawiam

ws
ID posta: 400565 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe