Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema Label
BildScreenshot zu Label Label-Seite mit Beispielarbeitsmappe aufrufen

Erstellung eines Arrays mit Loopfunktion

Betrifft: Erstellung eines Arrays mit Loopfunktion von: toteitote
Geschrieben am: 13.09.2014 19:24:08

Hallo miteinander,
ich habe gerade erst angefangen mich mit der Thematik VBA zu beschäftigen. In meiner Haushaltsliste habe ich 31 Labels zur Verfügung, die in Spalte 9 Worksheet 3 angegeben werden können. Ich bin bestrebt, dass die Farbkennung der Labels in der Spalte automatisiert wird und hoffe, mir kann jemand mit etwas Expertise helfen dies zu Codieren. Ich habe bisher noch keinen Erfolg verzeichnen können, was die Effektivität des Codes anbelangt. Ich habe 6 Gruppen von Elementen, die ich erstmal aufliste:

Gr.1: E1,E2,E3,EE1,EE2,EE3,EE4 (RGB(0, 128, 0)/Index Nr.10)
Gr.2: T1,T2,T3,T4,T5,TT1,TT2,TT3 (RGB(0, 204, 255)/Index Nr.28)
Gr.3: Z1,Z2,Z3 (RGB(153, 51, 0)/Index Nr.53)
Gr.4: U1,U2,U3 (RGB(153, 51, 102)/Index Nr.54)
Gr.5: K,TEC,NEC (RGB(51, 51, 51)/Index Nr.56)
Gr.6: STR,ENT,KUR,SOF,SER,ORG,RE (RGB(255, 0, 0)/Index Nr.3)

Ich habe einen gebrechlichen Anfang gewagt mit einem Loop ohne Dim oder Arrayparameter... Funktioniert leider nicht Ansatzweise und ich wäre Dankbar über den ein oder anderen Tip, wie das praktikabel in die Tat umzusetzen ist...

Sub Geldhaushalt()
Do While Col(9).Value = Empty
    Select Case IsEmpty(ActiveCell)
    Case True
        Case Else
        Select Case ActiveCell.HasText
        Case True
            If ActiveCell.Text = "E1" Then
               ActiveCell.Interior.Color = RGB(0, 128, 0)
            ElseIf ActiveCell.Text = "NEC" Then
                ActiveCell.Interior.Color = RGB(51, 51, 51)
            Else
            ClearContents
                With Selection.Interior
                    .Pattern = xlNone
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            End If
        End Select
    End Select
Loop
End Sub
Die Liste: https://www.herber.de/bbs/user/92613.xlsm

  

Betrifft: AW: Erstellung eines Arrays mit Loopfunktion von: Adis
Geschrieben am: 19.09.2014 13:40:46

Hallo

ich habe das obige Makro getestet, es laeuft nicht! Bekomme Run-Time Fehlermeldung
Dafür gibt es wahrscheinlich mehrere Gründe, Fehler im Programm und Denkfehler.

Der erste grundlegende Fehler liegt hier. Do While Col(9).Value = Empty
Die Spalte 9 ist ja nicht ganz leer, es gibt Daten und die Überschriftszeile.
Dann wird eine AktiveCelle ausgewertet, aber welche Zelle ist denn hier aktiv?
Das kann eine x beliebige sein, denn Aktiv ist gerade die wo der Cursor steht!
Probleme machten bei mir auch: .TintAndShade = 0 + .PatternTintAndShade = 0
Unklar ist der Befehl ClearContents, weil er ohne Bereichangabe nicht laeuft.

Ich habe das Programm mal soweit geaendert das es wenigstens über z=Zeile laeuft.
Die Kategorie haette ich über ein Makro ausgewrtet, anstatt so komplizierte Formeln.
Der FarbIndex laesst sich auch per Makro über die Spalte M ermitteln und einfügen.

Sub Geldhaushalt()
Dim z:  z = 4
Columns(9).Interior.ColorIndex = xlNone
Do Until Cells(z, "I") = Empty
    Select Case IsEmpty(Cells(z, "I"))
    Case True
    Case Else
        Select Case IsEmpty(Cells(z, "I"))
        Case False
            If Cells(z, "I").Text = "E1" Then
               Cells(z, "I").Interior.Color = RGB(0, 128, 0)
            ElseIf Cells(z, "I").Text = "NEC" Then
                Cells(z, "I").Interior.Color = RGB(51, 51, 51)
            Else
'                Cells(z, "I").ClearContents
                With Selection.Interior
                    .Pattern = xlNone
                    .ColorIndex = xlNone
'                    .TintAndShade = 0
'                    .PatternTintAndShade = 0
                End With
            End If
        End Select
    End Select
    z = z + 1
Loop
End Sub
Gruss Adis

PS eins kann mein Programm nicht: -finanzieren-


  

Betrifft: AW: Erstellung eines Arrays mit Loopfunktion von: Peter
Geschrieben am: 19.09.2014 16:37:38

Danke für die Antwort, ich habe an dem code mittlerweile einiges geändert, sodass das gedachte Array auch korrekt angesprochen wird. Es läuft jetzt alles, wie ich mir es vorgestellt habe;

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngcell As Range
Dim Bereich As Range
Set Bereich = ActiveSheet.Range(Cells(4, 9), Cells(1000, 9))
If Target.Column = 9 Then
For Each rngcell In Bereich
        
        Select Case Trim$(rngcell.Value)
        
      'Gruppe 1
      Case "E1", "E2", "E3", "EE1", "EE2", "EE3", "EE4"
        rngcell.Interior.Color = RGB(0, 128, 0)
        rngcell.Interior.Pattern = xlGray50
        rngcell.Font.Bold = True
        rngcell.Font.Color = RGB(255, 255, 255)
      'Gruppe 2
      Case "T1", "T2", "T3", "T4", "T5", "TT1", "TT2", "TT3"
        rngcell.Interior.Color = RGB(0, 204, 255)
        rngcell.Interior.Pattern = xlGray50
        rngcell.Font.Bold = True
        rngcell.Font.Color = RGB(255, 255, 255)
      'Gruppe 3
      Case "Z1", "Z2", "Z3"
        rngcell.Interior.Color = RGB(153, 51, 0)
        rngcell.Interior.Pattern = xlGray50
        rngcell.Font.Bold = True
        rngcell.Font.Color = RGB(255, 255, 255)
      'Gruppe 4
      Case "U1", "U2", "U3"
        rngcell.Interior.Color = RGB(153, 51, 102)
        rngcell.Interior.Pattern = xlGray50
        rngcell.Font.Bold = True
        rngcell.Font.Color = RGB(255, 255, 255)
      'Gruppe 5
      Case "K", "TEC", "NEC"
        rngcell.Interior.Color = RGB(51, 51, 51)
        rngcell.Interior.Pattern = xlGray50
        rngcell.Font.Bold = True
        rngcell.Font.Color = RGB(255, 255, 255)
      'Gruppe 6
      Case "STR", "ENT", "KUR", "SOF", "SER", "ORG", "RE"
        rngcell.Interior.Color = RGB(255, 0, 0)
        rngcell.Interior.Pattern = xlGray50
        rngcell.Font.Bold = True
        rngcell.Font.Color = RGB(255, 255, 255)
      '.. und ansonsten
      Case ""
        rngcell.Interior.Color = xlNone
        rngcell.Font.Bold = False
        rngcell.Font.Color = RGB(0, 0, 0)
    End Select
Next
Set Bereich = Nothing
End If
End Sub



 

Beiträge aus den Excel-Beispielen zum Thema "Erstellung eines Arrays mit Loopfunktion"