VBA Schriftfarbe für Bereich direkt über Arraywerte

[LB1972]

Guten Abend zusammen,

ich würde gerne folgendes hinkriegen:
in einem Prozedurablauf soll ein Array mit Werten bestückt werden (Zahlen für ColorIndex), die anschließend "auf einen Schlag" einem dazu passenden Zellbereich "übergestülpt" wird. Mein (nicht funktionierender) Code (Button "Schriftfarbe einbringen funktioniert leider nicht")

Code:

Sub NichtFunktionierendesSubSchriftfarbe()


   Dim myarray As Variant
   Dim i As Integer
   
   ReDim myarray(1 To 10, 1 To 1)
   
       For i = 1 To 10
           myarray(i, 1) = 42
       Next i
   
   Range("TestBereich").Cells(1, 1).Resize(UBound(myarray), 1).Font.ColorIndex = myarray

End Sub

bringt einen Fehler 13 - "Typen unverträglich".

Das Einbringen von Zellwerten mit der analogen Vorgehensweise (Button "Werte einbringen funktioniert") läuft einwandfrei.

Der Umweg, die Arraywerte via Schleife Stück für Stück auf den Zellbereich zu übertragen (Button "Schriftfarbe funktioniert aber unschön") läuft problemlos, ist aber zeitintensiver.

Kennt jemand von euch einen Weg, die Arraywerte direkt auf die Schriftfarbe der Zellen zu übertragen?
Danke schon mal für eure Unterstützung.
Gruß Ludwig

[schauan]

Halöchen,

statt myarray würde ich in diesem Fall gleich die 42 nehmen Der Code soll aber sicher nur die Vorgehensweise verdeutlichen, es würde ja nur Sinn machen, wenn da unterschiedliche Zahlen drin stehen.

Da muss ich Dich leider enttäuschen. wenn nicht jede Zeile eine andere Farbe hat könntest Du höchstens versuchen, jeweils einzelne Bereiche gleicher Farbe "auf einen Schlag" zu behandeln.

[LB1972]

Hallo Andre (Schauan),

Der Code soll aber sicher nur die Vorgehensweise verdeutlichen,

du hast mich durchschaut :19: . (Sorry, so viel Zeit für einen Kalauer muss schon sein...).
Ernsthaft:
Danke für die Rückmeldung. Ich hatte schon befürchtet, dass mein Plan nicht aufgeht. Deine Einschätzung bringt mich da weiter. Übrigens auch deine Idee, das blockweise anzugehen (wir reden im konkreten Fall von zwei bis drei Farben); ich werde das gleich mal versuchen.
Gruß Ludwig

[Steffl]

Hallo,

wenn man die Zellen einzeln ändert, geht es

PHP-Code:

Sub NichtFunktionierendesSubSchriftfarbe()


   Dim myarray As Variant
   Dim i As Integer
   
   ReDim myarray(1 To 10, 1 To 1)
   
       For i = 1 To 10
           myarray(i, 1) = 42
       Next i
   
'   Range("A1").Cells(1, 1).Resize(UBound(myarray, 1), 1).Font.ColorIndex = myarray(10, 1)
   For i = LBound(myarray, 1) To UBound(myarray, 1)
      Range("Testbereich").Cells(i).Font.ColorIndex = myarray(i, 1)
   Next i
End Sub 


[LB1972]

Servus zusammen,

so, mittlerweile habe ich
das mal eingebastelt (+ die Farbenvielfalt erhöht :19: ) und sieht so aus:

Code:

Sub KompromissSubSchriftfarbe()

   Dim myarray As Variant
   Dim i As Integer, k As Integer, l As Integer
   Dim myRange As Range
   Dim Zeit1 As Date, Zeit2 As Date

   
   ReDim myarray(1 To 10, 1 To 1)
   
       For i = 1 To 10
           Select Case i
               Case 1, 4, 9
                   myarray(i, 1) = 20
               Case 2, 3, 7
                   myarray(i, 1) = 30
               Case Else
                   myarray(i, 1) = 42
           End Select
       Next i
   
   Set myRange = Range("TestBereich").Offset(, -1)
   
   myRange.Cells(1, 1).Resize(UBound(myarray), 1).Value = myarray
   
   Set myRange = myRange.Offset(-1).Resize(Range("TestBereich").Rows.Count + 1)
   
   myRange.Cells(1, 1).Value = "Spaltenkopf"
   
   Application.ScreenUpdating = False
   
   Range("TestBereich").Select
   
       Zeit1 = Now
       For l = 1 To 1000
   
       k = 20
       
       myRange.AutoFilter Field:=1, Criteria1:=k
       Selection.Font.ColorIndex = k
       
       k = 30
       
       myRange.AutoFilter Field:=1, Criteria1:=k
       Selection.Font.ColorIndex = k
       
       k = 42
       
       myRange.AutoFilter Field:=1, Criteria1:=k
       Selection.Font.ColorIndex = k
       
       myRange.AutoFilter
   
         Next l
   
       Zeit2 = Now
       
   myRange.ClearContents

   Application.ScreenUpdating = True
       MsgBox (Zeit2 - Zeit1) * 24 * 3600 & " s"

End Sub

@Andre, war das in etwa dein Gedanke?

@ Stefan, deinen Vorschlag habe ich auch getestet; er entspricht wohl meinem "Schriftfarbe funktioniert aber unschön"-Knopf.

Ich hab alle Prozeduren mal "unter Stress gesetzt" (1.000 x Durchlauf) und die Zeiten gestoppt:
Stefan, du liegst (bei meiner Rechnergeschwindigkeit) mit 10s gleichauf mit meiner "unschönen".
Die Wunschprodezur, die leider nur auf Werte anwendbar ist, läge bei <1 s.
Der von mir oben beschriebene Kompromissweg (inspiriert von Andre) braucht 4 s.
Verbesserungsvorschläge sind willkommen.
Danke und
Gruß Ludwig

[schauan]

Hallöchen,

die produktive Variante läuft dann aber ohne Schleife:

Code:

Sub KompromissSubSchriftfarbeAS()
    Dim myarray As Variant
    Dim i As Integer, k As Integer, l As Integer
    Dim myRange As Range
    Dim Zeit1 As Date, Zeit2 As Date
    
    ReDim myarray(1 To 1000, 1 To 1)
        For i = 1 To 1000
            Select Case i Mod 10
                Case 1, 4, 9
                    myarray(i, 1) = 20
                Case 2, 3, 7
                    myarray(i, 1) = 30
                Case Else
                    myarray(i, 1) = 42
            End Select
        Next i
    Set myRange = Range("TestBereich").Resize(1000, 1).Offset(, -1)
    myRange.Cells(1, 1).Resize(UBound(myarray), 1).Value = myarray
    Set myRange = myRange.Offset(-1) '.Resize(Range("TestBereich").Rows.Count + 1)
    myRange.Offset(-1, 1).Cells(1, 1).Value = "Spaltenkopf"
    Application.ScreenUpdating = False
    myRange.Offset(, 1).Select
    'Range("TestBereich").Select
        
        Zeit1 = Now
        k = 20
        myRange.AutoFilter Field:=1, Criteria1:=k
        Selection.Font.ColorIndex = k
        k = 30
        myRange.AutoFilter Field:=1, Criteria1:=k
        Selection.Font.ColorIndex = k
        k = 42
        myRange.AutoFilter Field:=1, Criteria1:=k
        Selection.Font.ColorIndex = k
        
        myRange.AutoFilter
    
        Zeit2 = Now
    myRange.ClearContents
    Application.ScreenUpdating = True
    MsgBox (Zeit2 - Zeit1) * 24 * 3600 & " s"
End Sub

[LB1972]

Guten Morgen Andre,

da hast du recht.
Die Schleife ist nicht nötig; die habe ich für meinen "Stress-Test" eingebaut (1000 x Durchlauf - 999 davon als Zugabe - für den Vergleich der diskutierten Herangehensweisen).
Danke und Gruß Ludwig