Clever-Excel-Forum

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

Halöchen,

statt myarray würde ich in diesem Fall gleich die 42 nehmen Smile

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.

Hallo Andre (Schauan),

Zitat: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

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 

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

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

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

LB1972

schauan

LB1972

Steffl

LB1972

schauan

LB1972