Kleur lettertype overnemen uit een tabel

[Gert Bouwmeeste]

Beste allemaal,

Ik heb het volgende probleem/vraag. Ik heb een afdelingstabel met een paar duizend codes. Iedere ochtend krijg ik uit het mainframe een download met de organisatiestructuur. Die wordt bewerkt en geeft dan de organisatie weer (zie bijgaand voorbeeld, bovenste deel).

In de tabel met afdelingsnummers hebben sommige nummers een kleur. Die duidt de actie aan die nog uitgevoerd moet worden (rood = verwijderen, blauw = naam veranderen) voor die afdeling.

Wat ik zoek is een macro o.i.d. die de waarde van de cel in kolom O op het tabblad "Structuur" zoekt in de tabel in kolom Aop het tabblad "Afdelingen" . Vervolgens de kleur bepaalt van de gevonden code en die kleurcode dan toepast op alle niet-blanco cellen op de regel op tabblad "Structuur" in de kolommen A t/m U. Zodat het er uit komt te zien zoals het onderste deel van het voorbeeld.

Misschien een ingewikkeld verhaal, maar ik hoop dat iemand mij kan helpen.

 

[Finch]

Hieronder wat code die je op weg moet helpen het probleem op te lossen. Error trapping, enz. is niet aanwezig.

Sub Kleuren()
Dim rngCell As Range
Dim rngAfdeling As Range
Dim Kleur As Variant
For Each rngCell In Sheets("structuur").Range("O2:O" & Sheets("structuur").Range("O2").End(xlDown).Row)
    Set rngAfdeling = Sheets("afdelingen").Range("A2:A" & Sheets("afdelingen").Range("A2").End(xlDown).Row).Find(rngCell.Value)
    If Not rngAfdeling Is Nothing Then
        Kleur = rngAfdeling.Font.Color
        rngCell.EntireRow.SpecialCells(xlCellTypeConstants).Font.Color = Kleur
        rngCell.EntireRow.SpecialCells(xlCellTypeFormulas).Font.Color = Kleur    'Mag eventueel geschrapt worden
    End If
Next rngCell
End Sub

 

[snb]

Sub tst()
  sq = Sheets("Structuur").Columns(15).SpecialCells(2)
  st = Sheets("Afdelingen").Columns(1).SpecialCells(2)
  For j = 1 To UBound(sq)
    st(j, 1) = st(j, 1) & "|" & Sheets("Afdelingen").Columns(1).SpecialCells(2).Cells(j).Font.ColorIndex
  Next
  st = WorksheetFunction.Transpose(st)
  For j = 2 To UBound(sq)
    Sheets("Structuur").Columns(15).SpecialCells(2).Cells(j).EntireRow.Font.ColorIndex = Replace(Replace(Join(Filter(st, sq(j, 1)), ""), sq(j, 1) & "|", ""), "-4105", 0)
  Next
End Sub

 

[Gert Bouwmeeste]

@SNB

De code loopt en doet het goed, totdat na 1079 regels de melding komt:
Fout 1004 tijdens uitvoering
Eigenschap Colorindex van klasse Font kan niet worden ingesteld

@Finch
Code loopt prima en heeft in circa 15 seconden alle 3.900 regels doorlopen en correct aangepast.

Dank je wel!

 

[Finch]

@SNB

De code loopt en doet het goed, totdat na 1079 regels de melding komt:
Fout 1004 tijdens uitvoering
Eigenschap Colorindex van klasse Font kan niet worden ingesteld

@Finch
Code loopt prima en heeft in circa 15 seconden alle 3.900 regels doorlopen en correct aangepast.

Dank je wel!

Nu ik dat zo terug bekijk en het toch over een aantal records gaat, is een andere insteek misschien sneller.

Indien de mogelijkheid bestaat om met een (tijdelijke) hulpkolom te werken, kan je in de lijst van de afdelingen bepalen welke kleuren er allemaal gebruikt worden, en dan de kleuren die niet voldoen aan de standaardkleur (waarschijnlijk zwart) via een filter die overeenkomstige afdelingen ophalen en dan via een filters gaan werken op het blad met je gegevensexport. Op die manier moet je niet doorheen alle cellen lopen, en zal het wel sneller werken. Kan je je vinden in die werkwijze? Ik zal die misschien in de loop van de namiddag even uitwerken.

 

[snb]

Kijk dan eens wat voor colorindex het gegeven in kolom A van sheet afdeling heeft dat overeenkomt met het nummer in rij 1079 van sheet structuur of vervang colorindex door color

 

[Gert Bouwmeeste]

Kan je je vinden in die werkwijze? Ik zal die misschien in de loop van de namiddag even uitwerken.

Finch,

Dat hoeft niet. Het is prima zo en het wordt maar 1 x per dag gebruikt. In 15 seconden kan ik nog geen koffie halen, zal ik maar zeggen.

Het aantal kleuren is erg beperkt.
1=zwart
3 = rood
5 = blauw
50=zeegroen

Maar je hoeft er verder niets meer voor te doen. Ik ben hier al heel erg blij mee.

Groet,
Gert

 

[Gert Bouwmeeste]

Kijk dan eens wat voor colorindex het gegeven in kolom A van sheet afdeling heeft dat overeenkomt met het nummer in rij 1079 van sheet structuur of vervang colorindex door color

Regel 1079 = rood (code 3) en wordt nog aangepast. Regel 1080 =zwart (code 1) en die is daarvoor al vele malen voorgekomen.

Veranderen van ColorIndex in Color heeft geen effect, macro stop met dezelfde foutmelding op dezelfde regel.
Fout 1004 tijdens uitvoering
Eigenschap Color van klasse Font kan niet worden ingesteld

 

[Finch]

Finch,

Dat hoeft niet. Het is prima zo en het wordt maar 1 x per dag gebruikt. In 15 seconden kan ik nog geen koffie halen, zal ik maar zeggen.

Het aantal kleuren is erg beperkt.
1=zwart
3 = rood
5 = blauw
50=zeegroen

Maar je hoeft er verder niets meer voor te doen. Ik ben hier al heel erg blij mee.

Groet,
Gert

Ik was er al aan bezig dus zal dan ook maar de code posten die ik heb op dit moment. Dit is wel geen "mooie" code, die was gewoon maar om te testen of mijn idee haalbaar was. En kan dus zeker nog verfijnd worden, maar toch ben ik eens benieuwd hoelang deze methode zou doen over de opmaak ivg met de voorgaande. Wil je dat even testen?

Sub Kleuren()

Dim rngAfdeling As Range
Dim colKleuren As Collection
Dim colAfdeling As Collection
Dim arrFilter As Variant

Set colKleuren = New Collection
Sheets("afdelingen").Range("B1").EntireColumn.Insert
Sheets("afdelingen").Range("B1") = "Kleur"
For Each rngAfdeling In Sheets("afdelingen").Range("A2:A" & Sheets("afdelingen").Range("A2").End(xlDown).Row)
    rngAfdeling.Offset(0, 1) = rngAfdeling.Font.Color
    On Error Resume Next
    colKleuren.Add rngAfdeling.Font.Color, CStr(rngAfdeling.Font.Color)
    On Error GoTo 0
Next rngAfdeling
For i = 1 To colKleuren.Count
    If colKleuren(i) <> 0 Then
    eindrijAfdeling = Sheets("afdelingen").Range("A1").End(xlDown).Row
    With Sheets("afdelingen").Range("A1:B" & eindrijAfdeling)
        .AutoFilter field:=2, Criteria1:=colKleuren(i)
    Set colAfdeling = New Collection
    For Each cell In Sheets("afdelingen").Range("A2:A" & eindrijAfdeling).SpecialCells(xlCellTypeVisible)
            On Error Resume Next
            colAfdeling.Add cell, CStr(cell)
            On Error GoTo 0
    Next cell
    eindrijstructuur = Sheets("Structuur").Range("O2").End(xlDown).Row
    For j = 1 To colAfdeling.Count
        Sheets("Structuur").Range("A1:O" & eindrijstructuur).AutoFilter field:=15, Criteria1:=colAfdeling(j)
        Sheets("structuur").Range("O2:O" & eindrijstructuur).SpecialCells(xlCellTypeVisible).EntireRow.SpecialCells(xlCellTypeConstants).Font.Color = colKleuren(i)
    Next j
    End With
    Set colAfdeling = Nothing
    Sheets("Afdelingen").AutoFilterMode = False
    Sheets("structuur").AutoFilterMode = False
End If
  
Next i

Sheets("afdelingen").Range("B1").EntireColumn.Delete

End Sub

Nogmaals: niet kijken naar de sierlijkheid van de code, deze is beneden alle peil, maar was meer als proof-of-concept dan iets anders.

 

[snb]

Ik heb de fout ontdekt:

Sub tst()
  sq = Sheets("Structuur").Columns(15).SpecialCells(2)
  st = Sheets("Afdelingen").Columns(1).SpecialCells(2)
  For j = 1 To UBound([COLOR="Red"][B]st[/B][/COLOR])
    st(j, 1) = st(j, 1) & "|" & Sheets("Afdelingen").Columns(1).SpecialCells(2).Cells(j).Font.ColorIndex
  Next
  st = WorksheetFunction.Transpose(st)
  For j = 2 To UBound(sq)
    Sheets("Structuur").Columns(15).SpecialCells(2).Cells(j).EntireRow.Font.ColorIndex = Replace(Replace(Join(Filter(st, sq(j, 1)), ""), sq(j, 1) & "|", ""), "-4105", 0)
  Next
End Sub

Ik ben ook wel benieuwd hoelang deze code erover doet in jouw bestand.