✔ Excel (2003) select box feld abhängig der Auswahl farblich markieren.

S

südpol

Erfahrenes Mitglied
Hi,

ich habe ein Excel 2003 (sollte auch mit 2010 funktionieren) dokument in dem auf Tabellenblatt T1 eine Liste mit werten steht:
A1: AAA
A2: BBB
A3: CCC
A4: DDD
Jedes dieser Felder hat eine andere Hintergrundfarbe. Auf Tabellenblatt T2 gibt es nun Listboxen die diese Liste verwenden um eine Auswahl bereit zu stellen. Soweit kein Problem. Ich hätte nun aber gerne, dass bei der Auswahl von z. B. AAA auch die Farbe aus der Liste aus T1 übernommen wird. Ich vermute, dass ich das nur mit Hilfe eines macros machen kann. Kann mir jemand sagen wie?

Vielen Dank
 
Hier ein kurzes Beispiel, indem deine Daten als Benannter Bereich gespeichert sind:
Visual Basic: 
Private Sub Worksheet_Change(ByVal Target As Range)
    'verhindert Endlosschleife
    Application.EnableEvents = False

    'Es handelt sich bei der geänderten Zelle um die Drop-Downliste
    If Target.Row = 1 And Target.Column = 2 Then
        ThisWorkbook.Names("MyList").RefersToRange.Find(Target.Value).Copy
        Target.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End If
    
    Application.EnableEvents = True
End Sub
Der Code muss dabei im Code des Tabellenblattes, nicht in einem Modul!
Ohne Makro wüsste ich leider auch keine Lösung...
 
Hi!

Danke für die schnelle Antwort. Das hat mich schon sehr weit gebracht. Ich habe die Funktion etwas modifiziert damit ich für das relevante Tabellenblatt die Range nicht extra vorgeben muss:
Code: 
Sub Worksheet_Change(ByVal Target As Range)
    'verhindert Endlosschleife
    Application.EnableEvents = False
    
    If (IsNull(Workbooks(1).Names("short_name").RefersToRange.Find(Target.Value)) = False) Then
        'finde den Wert in der Referenztabelle
        Workbooks(1).Names("short_name").RefersToRange.Find(Target.Value).Copy
        
        'kopiere die Formatierung in das geänderte Feld
        Target.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End If

    
    Application.EnableEvents = True
End Sub
Probleme habe ich allerdings noch mit der if-Abfrage. Ich wollte damit erreichen, dass er die Formatierung nur dann kopiert, wenn er den Wert auch in der Tabelle findet. Leider funktioniert das nicht und die Fehlermeldung ist nicht sehr aussagekräftig. Hat jemand noch eine Idee wie ich prüfen kann ob der "find" erfolgreich war?
 
Probleme habe ich allerdings noch mit der if-Abfrage. Ich wollte damit erreichen, dass er die Formatierung nur dann kopiert, wenn er den Wert auch in der Tabelle findet.
Zum Vergrößern anklicken....

Probiere es mal mit
Visual Basic: 
If Not X Is Nothing Then 'X durch die Find Methode ersetzen

Hinweis: Persönlich würde ich .Find() aber nicht 2x ausführen. Speichere lieber das Ergebnis in einem Range-Objekt.
 
Hi,

danke für deine Hilfe! Das hat jetzt schon mal sehr gut funktionert:
Code: 
Sub Worksheet_Change(ByVal Target As Range)
    'verhindert Endlosschleife
    Application.EnableEvents = False
    
    'Prüfen ob die Zelle gefüllt ist
    If Target.Value <> "" Then
    
        Dim rng As Range
        Set rng = Workbooks(1).Names("audit_short_name").RefersToRange.Find(Target.Value)
        
        'Prüfen ob der Find Befehl etwas gefunden hat
        If Not rng Is Nothing Then
            'finde den Wert in der Referenztabelle
            rng.Find(Target.Value).Copy
            
            'kopiere die Formatierung in das geänderte Feld
            Target.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
        
    End If
 
    
    Application.EnableEvents = True
End Sub

Wenn ich nun aber Werte einer Selectbox durch "ziehen" in viele andere Zellen kopiere, dann steigt das VBA mit einem Fehler in der ersten If Abfrage aus (If Target.Value <> "" Then). Ich vermute mal, dass das daran liegt, dass hier kein Einzelwert mehr übergeben wird sondern eine range, oder? Wie kann ich das ggf. Abfangen / in eine Schleife umwandeln?
 
Ich vermute mal, dass das daran liegt, dass hier kein Einzelwert mehr übergeben wird sondern eine range, oder?
Zum Vergrößern anklicken....

Es ist immer eine Range, aber die Range ist nun größer. Überprüfen könntest du es z.B. so:

Visual Basic: 
Sub Worksheet_Change(ByVal Target As Range)
    If IsArray(Target) Then
        MsgBox ">1"
    Else
        MsgBox "=1"
    End If
End Sub

Wie kann ich das ggf. Abfangen / in eine Schleife umwandeln?
Zum Vergrößern anklicken....

Visual Basic: 
Sub Worksheet_Change(ByVal Target As Range)
    Dim IterCell As Range

    For Each IterCell In Target
        MsgBox IterCell.Value
    Next IterCell
End Sub
 
Hi,

ich habe das jetzt mal so zusammen gebaut wie ich es brauche - leider funktioniert jetzt nichts mehr und es kommt auch keine Fehlermeldung :-( Den Teil mit dem Suchen und übernehmen der Farbe hatte ich zwischenzeitlich schon in eine extra funktion ausgelagert - habe es zur Sicherheit jetzt aber wieder alles in eine Funktion geworfen. Leider ohne Erfolg :-(

Visual Basic: 
Sub Worksheet_Change(ByVal Target As Range)
    'verhindert Endlosschleife
    Application.EnableEvents = False
    If IsArray(Target) Then
        Dim IterCell As Range
        For Each IterCell In Target
            If IterCell.Value <> "" Then
                Dim rng As Range
                Set rng = Workbooks(1).Names("audit_short_name").RefersToRange.Find(IterCell.Value)
                
                'Prüfen ob der Find Befehl etwas gefunden hat
                If Not rng Is Nothing Then
                    'finde den Wert in der Referenztabelle
                    rng.Find(Target.Value).Copy
                    
                    'kopiere die Formatierung in das geänderte Feld
                    Target.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End If
            End If
        Next IterCell
    Else
        If Target.Value <> "" Then
            Dim rng As Range
            Set rng = Workbooks(1).Names("audit_short_name").RefersToRange.Find(Target.Value)
            
            'Prüfen ob der Find Befehl etwas gefunden hat
            If Not rng Is Nothing Then
                'finde den Wert in der Referenztabelle
                rng.Find(Target.Value).Copy
                
                'kopiere die Formatierung in das geänderte Feld
                Target.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End If
        End If
    End If
    
    Application.EnableEvents = True
End Sub

Kann mir jemand sagen was ich falsch mache oder wo ich vernünftige Fehlermeldungen / Debug Infos her bekomme? Einfach keine Meldung ist irgendwie blöd...
 
Ich wollte dir mit dem IsArray() nur sagen, wie du es überprüfen kannst, zum Abfangen reicht die Schleife. Find() auf rng ist überflüssig. Und es muss IterCell.PasteSpecial heißen in der Schleife.
 
Hi,

danke für deine Schnelle Antwort!

Ich habe das IsArrray jetzt entfernt und PasteSpecial umgestellt. Ich habe auch noch einen Fehler in der Copy Funktion gefunden und beseitigt. Leider scheint noch immer etwas falsch zu laufen. Die Farbe wird derzeit nicht übernommen :(

Visual Basic: 
Sub Worksheet_Change(ByVal Target As Range)
    'verhindert Endlosschleife
    Application.EnableEvents = False

    Dim IterCell As Range
    For Each IterCell In Target
        'prüfen ob die Zelle leer ist
        If IterCell.Value <> "" Then
            'finde den Wert in der Referenztabelle
            Dim rng As Range
            Set rng = Workbooks(1).Names("audit_short_name").RefersToRange.Find(IterCell.Value)
            
            'prüfen ob der Find Befehl etwas gefunden hat
            If Not rng Is Nothing Then
                'kopiere den Wert aus der Referenztabelle
                rng.Copy
                
                'kopiere die Formatierung in das geänderte Feld
                IterCell.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End If
        End If
    Next IterCell
    
    Application.EnableEvents = True
End Sub
 
Verstehe ich nicht, bei mir funktioniert der Code testweise wunderbar. Ich verwende derzeit Excel 2007, vielleicht gibt es bei PasteSpecial Unterschiede zu Excel, da kenne ich mich leider zu wenig aus.

Ansonsten könnte ich mir noch vorstellen, dass er die falsche Zelle als Bezug findet, es wird die erste Zelle genommen, die gefunden wird in der Range und aktuell verwendest du keinerlei Einschränkungen bei Find(). Probiere es z.B. mal mit .Find(IterCell, LookAt:=xlWhole)

Ohne das xlWhole wird beispielsweise 11 gefunden, wenn man 1 sucht und die 11 in diesen Fall vor der 1 in der Liste kommt.
 
Um antworten zu können musst du eingeloggt sein.

Neue Beiträge

Zurück