Live-Forum - Die aktuellen Beiträge
Datum
Titel
20.04.2024 00:49:19
Excel Sheet in einen Excel Kalender einfügen
20.04.2024 00:08:11
In Ordner nur das Speichern von Dateien erlauben
19.04.2024 21:26:15
mehrfache Texte finden
19.04.2024 19:41:34
Bei VBA Ausführung Anzeige einfrieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
900to904
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
900to904
900to904
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zellefarbe in Register übernehmen

Zellefarbe in Register übernehmen
04.09.2007 21:49:10
Lemmi
Hallo zusammen,
mein erstes Problem scheint ein Leistungs- / Kapazität zu sein! Allerdings habe ich noch ein VBA- Code Anpassung.
Ich habe vor einigen Tagen sehr gute Hilfe von fcs bekommen! Vielen Dank nochmals!
Er konnte mir leider einen Wunsch nicht erfüllen! Ich würde gerne in dem Marko die Zellfarbe auslesen. und diese in das Register einbringen!
Also wen das Makro ausgelöst wird, Übernimmt dieses aus einer Tabelle (Spalte C/H/I) Daten, kopiert Sie, und erzeugt mit selbigen Namen pro Zeile ein Register.
In der Spalte C sind bedingt Formatierte Zellen (A, B, C ) . Diese Farben würde ich gerne mit auslesen und das entsprechende Register einfärben.
https://www.herber.de/bbs/user/45689.xls
Gruß Lemmi

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zellefarbe in Register übernehmen
04.09.2007 21:54:00
Hajo_Zi
Hallo Lemmi,
die Farben der bedingten Formatierung auslesen ist das komplizierteste was ih kenne.
Schaue mal auf meine HP Seite Fremd VBA.

AW: Zellefarbe in Register übernehmen
04.09.2007 21:54:00
Gerd
Hi,
unvertretbarer Aufwand bedingte Formate auszulesen.
mfg Gerd

AW: Zellefarbe in Register übernehmen
04.09.2007 21:57:00
Herbert
"mein erstes Problem scheint ein Leistungs- / Kapazität zu sein!..."
Jein, wurde schon oft diskutiert, es gibt dazu keine gesicherten Erkenntnisse,
nur Umwege und die findest du z.B. in der Recherche.
mfg Herbert

AW: Zellefarbe in Register übernehmen
04.09.2007 22:03:42
Josef
Hallo Lemmi,
statt die bedingte Formatierung auszulesen, brauchst du doch nur die Bedingung abfragen und die entsprechende Farbe zuweisen.
Sub Basistabelle_Kopieren()
'Es sollten Register von den Geräten- Nr. 1- XX erzeugt werden!
'Es werden nur die Register erzeugt die in Spalte C und H einen Inhalt haben!(UND Verknüpfung)
'Wenn dies der Fall ist wird der Zellinhalt C6, H6 und I6 ausgelsen und mit diesem ein neues Register erzeugt!
Dim TB_Basis As Worksheet, TB_Ref As Worksheet, TB_Neu As Worksheet, RefDaten As Range
Dim KopieNr, Zelle As Range
KopieNr = InputBox("Kopie Nummer: " & vbLf & vbLf _
    & "Bei Nummer >1 wird die KopieNr in ( ) dem Blattnamen hinzugefügt", _
    "Tabellenblätter kopieren, Geräte- Nr. in Spalte C+ H+ I", 1)
If KopieNr = "" Then Exit Sub 'Abrechen wurde gewählt
Set TB_Basis = Worksheets("Kopie x mal")
Set TB_Ref = Worksheets("Basistabelle")
With TB_Ref
    'Bereich mit Daten in Spalte 3 (C)
    Set RefDaten = .Range(.Cells(6, 3), .Cells(.Rows.Count, 3).End(xlUp))
    For Each Zelle In RefDaten
        If Not IsEmpty(Zelle) Then
            TB_Basis.Copy After:=Worksheets(Worksheets.Count)
            Set TB_Neu = ActiveSheet
            TB_Neu.Name = Zelle.Text & " " & Zelle.Offset(0, 5).Text & _
                IIf(IsEmpty(Zelle.Offset(0, 6)), "", " " & Zelle.Offset(0, 6).Text) & _
                IIf(KopieNr = "1", "", "(" & KopieNr & ")")
            'Register einfärben
            If Application.Version >= 11 Then
                Select Case Zelle.Value
                    Case "A"
                        TB_Neu.Tab.ColorIndex = 34
                    Case "B"
                        TB_Neu.Tab.ColorIndex = 37
                    Case "C"
                        TB_Neu.Tab.ColorIndex = 24
                    Case Else
                End Select
            End If
            'Button in Kopie löschen
            TB_Neu.Shapes(1).Delete
        End If
    Next Zelle
End With
End Sub

Gruß Sepp

Anzeige
AW: Zellefarbe in Register übernehmen
05.09.2007 21:28:00
Lemmi
Hallo Sepp,
vielen Dank für Deine Antwort! Ich denke das die Lösung ein guter Ansatz ist.
Weil ich nun aber Naturgemäß nicht immer nur A, B oder C in Spalte C habe; fragte ich Dich, ob man vielleicht die Text/ Zahl Zellinhalte in Spalte C abragt und nach einer vorbestimmten Reihenfolge einfärbt. Diese vordeffinierte Reihenfolge der Farbpalette ist immer die gleiche.
z. B. Rot ,Grün Blau etc. Eine Farbe ändert sich nur wenn eine neue Nennung in Spalte C ins Spiel kommt.
D.h. ein beliebiger Text der in Spalte ab C6 erst genant wird, bekommt dann einen Farbcode z.B rot. Ist nun in der Spalte ein zweiter anderer Name vorhanden wird dieser grün eingefärbt . Der dritte andere Name würde dann blau sein....etc.
Wenn also die Neunennungen immer eine bestimmte Reihenfolge haben, dann kennt man in gewisser Weise doch auch die Registerfarbe. !
(Erstnennung immer rot ; Zweitnenneung immer grün....)
D.h. man liste erst die Spalte C aus und filter diese nach Doppelnennungen so dass nur eine Nennung vorhanden ist . Dann werden die Farben vergeben!
Kann man das irgendwie in einem VBA Code einbringen?
Gruß
Lemmi

Anzeige
AW: Zellefarbe in Register übernehmen
05.09.2007 21:57:13
Josef
Hallo Lemmi,
im Array "vColors" kannst du die Farbnummern angeben, die du verwenden willst.
Du kannst dort natürlich auch mehr als 3 Farben definieren.
Sub Basistabelle_Kopieren()
'Es sollten Register von den Geräten- Nr. 1- XX erzeugt werden!
'Es werden nur die Register erzeugt die in Spalte C und H einen Inhalt haben!(UND Verknüpfung)
'Wenn dies der Fall ist wird der Zellinhalt C6, H6 und I6 ausgelsen und mit diesem ein neues Register erzeugt!
Dim TB_Basis As Worksheet, TB_Ref As Worksheet, TB_Neu As Worksheet, RefDaten As Range
Dim KopieNr, Zelle As Range

Dim vColors() As Variant, intColor As Integer, vAct As Variant

vColors = Array(34, 37, 24) 'Die Farbnummern. Beliebig erweiterbar!

KopieNr = InputBox("Kopie Nummer: " & vbLf & vbLf _
    & "Bei Nummer >1 wird die KopieNr in ( ) dem Blattnamen hinzugefügt", _
    "Tabellenblätter kopieren, Geräte- Nr. in Spalte C+ H+ I", 1)

If KopieNr = "" Then Exit Sub 'Abrechen wurde gewählt

Set TB_Basis = Worksheets("Kopie x mal")
Set TB_Ref = Worksheets("Basistabelle")

With TB_Ref
    'Bereich mit Daten in Spalte 3 (C)
    Set RefDaten = .Range(.Cells(6, 3), .Cells(.Rows.Count, 3).End(xlUp))
    
    For Each Zelle In RefDaten
        
        If Not IsEmpty(Zelle) Then
            
            If vAct = "" Then
                vAct = Zelle.Value
            ElseIf vAct <> Zelle.Value Then
                intColor = intColor + 1
                vAct = Zelle.Value
            End If
            
            If intColor > UBound(vColors) Then intColor = 0
            
            TB_Basis.Copy After:=Worksheets(Worksheets.Count)
            Set TB_Neu = ActiveSheet
            
            TB_Neu.Name = Zelle.Text & " " & Zelle.Offset(0, 5).Text & _
                IIf(IsEmpty(Zelle.Offset(0, 6)), "", " " & Zelle.Offset(0, 6).Text) & _
                IIf(KopieNr = "1", "", "(" & KopieNr & ")")
            
            'Register einfärben
            If Application.Version >= 11 Then
                TB_Neu.Tab.ColorIndex = vColors(intColor)
            End If
            
            'Button in Kopie löschen
            TB_Neu.Shapes(1).Delete
        End If
        
    Next Zelle
    
End With

End Sub


Gruß Sepp

Anzeige
AW: Zellefarbe in Register übernehmen
05.09.2007 22:26:00
Lemmi
Hallo Sepp ,
vielen Dank für Deine Hilfe!
Ich habe das Mako gerade ausprobiert! Veileicht könnte es sein, dass ich mich zu unverständlich ausgedrückt habe. Es findet zwar in einer bestimmten Reihenfolge die Farbanpassung im Register statt, Marko erfüllt genau dass was ich mir vorstelle, wenn nun eine Nennung sich wiederholt sollte diese auch die gleiche Farbe erhalten!
Zeile C
A ........ rot,
B ......... grün,
C ........ blau,
C ........ blau,
C ........ blau,
A ........ rot,...........gleiche Farbe wie schon einmal vergeben!
B ......... grün, etc.
Gruß
Lemmi

Anzeige
AW: Zellefarbe in Register übernehmen
05.09.2007 22:54:55
Josef
Hallo Lemmi,
das sollte es tun.
Sub Basistabelle_Kopieren()
'Es sollten Register von den Geräten- Nr. 1- XX erzeugt werden!
'Es werden nur die Register erzeugt die in Spalte C und H einen Inhalt haben!(UND Verknüpfung)
'Wenn dies der Fall ist wird der Zellinhalt C6, H6 und I6 ausgelsen und mit diesem ein neues Register erzeugt!
Dim TB_Basis As Worksheet, TB_Ref As Worksheet, TB_Neu As Worksheet, RefDaten As Range
Dim KopieNr, Zelle As Range

Dim vValues() As Variant, lngV As Long
Dim vColors() As Variant, intColor As Integer

vColors = Array(34, 37, 24, 41, 52, 17, 27) 'Die Farbnummern. Beliebig erweiterbar!

KopieNr = InputBox("Kopie Nummer: " & vbLf & vbLf _
    & "Bei Nummer >1 wird die KopieNr in ( ) dem Blattnamen hinzugefügt", _
    "Tabellenblätter kopieren, Geräte- Nr. in Spalte C+ H+ I", 1)

If KopieNr = "" Then Exit Sub 'Abrechen wurde gewählt

Set TB_Basis = Worksheets("Kopie x mal")
Set TB_Ref = Worksheets("Basistabelle")

With TB_Ref
    'Bereich mit Daten in Spalte 3 (C)
    Set RefDaten = .Range(.Cells(6, 3), .Cells(.Rows.Count, 3).End(xlUp))
    
    For Each Zelle In RefDaten
        
        If Not IsEmpty(Zelle) Then
            If lngV = 0 Then
                Redim vValues(lngV)
                vValues(lngV) = Zelle.Value
                lngV = lngV + 1
            Else
                If IsError(Application.Match(Zelle.Value, vValues, 0)) Then
                    Redim Preserve vValues(lngV)
                    vValues(lngV) = Zelle.Value
                    lngV = lngV + 1
                End If
            End If
        End If
        
    Next
    
    For Each Zelle In RefDaten
        
        If Not IsEmpty(Zelle) Then
            
            intColor = Application.Match(Zelle.Value, vValues, 0)
            
            If intColor > UBound(vColors) Then intColor = UBound(vColors)
            
            TB_Basis.Copy After:=Worksheets(Worksheets.Count)
            Set TB_Neu = ActiveSheet
            
            TB_Neu.Name = Zelle.Text & " " & Zelle.Offset(0, 5).Text & _
                IIf(IsEmpty(Zelle.Offset(0, 6)), "", " " & Zelle.Offset(0, 6).Text) & _
                IIf(KopieNr = "1", "", "(" & KopieNr & ")")
            
            'Register einfärben
            If Application.Version >= 11 Then
                TB_Neu.Tab.ColorIndex = vColors(intColor)
            End If
            
            'Button in Kopie löschen
            TB_Neu.Shapes(1).Delete
        End If
        
    Next Zelle
    
End With

End Sub


Gruß Sepp

Anzeige
AW: Zellefarbe in Register übernehmen
06.09.2007 08:15:00
Lemmi
Hallo Sepp,
wau, perfekt, Danke, Danke!
Ich bin ja versucht noch eine "Kleinigkeit" zu fragen! Ich frage einfach oder?!?
Da jetzt die Farbreihenfolge festliegt und der Modus damit eindeutig ist, kann man dies ja auch in die Saplte C übertragen.
Ich würde gerne ein Marko haben welches die Spalte C mit ihren Inhalten in der selben Reihenfolge (Modus) kennzeichnet!
Die Farbreihenfolge sollte/ kann manuell vom ersten Marko übertragen werden! (Ist vieleicht etwas unabhängiger und könnte vielfältiger eingesetzt werden!)
Wäre das noch möglich? Vielen Dank im Voraus!
Gruß
Lemmi

Anzeige
AW: Zellefarbe in Register übernehmen
06.09.2007 12:21:51
Josef
Hallo Lemmi,
entferne die bedingte Formatierung aus Spalte "C" und füge im Code vor der Kommentarzeile "'Register färben" diesen Code ein.
'Zelle färben
Zelle.Interior.ColorIndex = vColors(lngColor)

Gruß Sepp

AW: Zellefarbe in Register übernehmen
06.09.2007 12:57:13
Lemmi
Hallo Sepp,
ich habe nicht : Zelle.Interior.ColorIndex = vColors(lngColor) eingestetzt sondern
........... (intColor) eingestzt, wie es bei
Register einfärben
............(intColor) geschrieben steht!
Ich weis zwar nicht warum, aber es funktioniert so! ....
..............."Die Farbreihenfolge sollte/ kann manuell vom ersten Marko übertragen werden! (Ist vielleicht etwas unabhängiger und könnte vielfältiger eingesetzt werden!......."
Damit meinte ich, dass mir zur Zeit ein eigenständiges Makro lieber währe!
Ist das noch möglich?
Gruß
Lammi

Anzeige
AW: Zellefarbe in Register übernehmen
06.09.2007 13:40:47
Josef
Hallo Lemmi,
klar geht das auch, ich hab dich wohl falsch verstanden.
Die Farbwerte habe ich in eine Funktion "mxColors()" ausgegliedert.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Basistabelle_Kopieren()
'Es sollten Register von den Geräten- Nr. 1- XX erzeugt werden!
'Es werden nur die Register erzeugt die in Spalte C und H einen Inhalt haben!(UND Verknüpfung)
'Wenn dies der Fall ist wird der Zellinhalt C6, H6 und I6 ausgelsen und mit diesem ein neues Register erzeugt!
Dim TB_Basis As Worksheet, TB_Ref As Worksheet, TB_Neu As Worksheet, RefDaten As Range
Dim KopieNr, Zelle As Range

Dim lngV As Long
Dim vColors As Variant, lngColor As Long

vColors = myColors

KopieNr = InputBox("Kopie Nummer: " & vbLf & vbLf _
    & "Bei Nummer >1 wird die KopieNr in ( ) dem Blattnamen hinzugefügt", _
    "Tabellenblätter kopieren, Geräte- Nr. in Spalte C+ H+ I", 1)

If KopieNr = "" Then Exit Sub 'Abrechen wurde gewählt

Set TB_Basis = Worksheets("Kopie x mal")
Set TB_Ref = Worksheets("Basistabelle")

With TB_Ref
    'Bereich mit Daten in Spalte 3 (C)
    Set RefDaten = .Range(.Cells(6, 3), .Cells(.Rows.Count, 3).End(xlUp))
    
    For Each Zelle In RefDaten
        
        If Not IsEmpty(Zelle) Then
            If lngV = 0 Then
                Redim vValues(lngV)
                vValues(lngV) = Zelle.Value
                lngV = lngV + 1
            Else
                If IsError(Application.Match(Zelle.Value, vValues, 0)) Then
                    Redim Preserve vValues(lngV)
                    vValues(lngV) = Zelle.Value
                    lngV = lngV + 1
                End If
            End If
        End If
        
    Next
    
    For Each Zelle In RefDaten
        
        If Not IsEmpty(Zelle) Then
            
            lngColor = Application.Match(Zelle.Value, vValues, 0)
            
            If lngColor > UBound(vColors) Then lngColor = UBound(vColors)
            
            TB_Basis.Copy After:=Worksheets(Worksheets.Count)
            Set TB_Neu = ActiveSheet
            
            TB_Neu.Name = Zelle.Text & " " & Zelle.Offset(0, 5).Text & _
                IIf(IsEmpty(Zelle.Offset(0, 6)), "", " " & Zelle.Offset(0, 6).Text) & _
                IIf(KopieNr = "1", "", "(" & KopieNr & ")")
            
            'Zelle färben
            Zelle.Interior.ColorIndex = vColors(lngColor)
            
            'Register einfärben
            If Application.Version >= 11 Then
                TB_Neu.Tab.ColorIndex = vColors(lngColor)
            End If
            
            'Button in Kopie löschen
            TB_Neu.Shapes(1).Delete
        End If
        
    Next Zelle
    
End With

End Sub


Sub ZellenFaerben()
Dim TB_Ref As Worksheet, RefDaten As Range
Dim KopieNr, Zelle As Range
Dim lngV As Long
Dim vColors As Variant, lngColor As Long

vColors = myColors

Set TB_Ref = Worksheets("Basistabelle")

With TB_Ref
    'Bereich mit Daten in Spalte 3 (C)
    Set RefDaten = .Range(.Cells(6, 3), .Cells(.Rows.Count, 3).End(xlUp))
    
    For Each Zelle In RefDaten
        
        If Not IsEmpty(Zelle) Then
            If lngV = 0 Then
                Redim vValues(lngV)
                vValues(lngV) = Zelle.Value
                lngV = lngV + 1
            Else
                If IsError(Application.Match(Zelle.Value, vValues, 0)) Then
                    Redim Preserve vValues(lngV)
                    vValues(lngV) = Zelle.Value
                    lngV = lngV + 1
                End If
            End If
        End If
        
    Next
    
    For Each Zelle In RefDaten
        
        If Not IsEmpty(Zelle) Then
            
            lngColor = Application.Match(Zelle.Value, vValues, 0)
            
            If lngColor > UBound(vColors) Then lngColor = UBound(vColors)
            
            'Zelle färben
            Zelle.Interior.ColorIndex = vColors(lngColor)
            
        End If
        
    Next Zelle
    
End With
End Sub

Private Function myColors() As Variant
myColors = Array(34, 37, 24, 41, 52, 17, 27) 'Die Farbnummern. Beliebig erweiterbar!
End Function

Gruß Sepp

Anzeige
AW: Zellefarbe in Register übernehmen
07.09.2007 21:35:00
Lemmi
Hallo Sepp,
vielen Dank für Deine umfangreiche Hilfe!
Ich weis nicht so recht ob ich einen Fehler beim Ausführen des Code's mache oder im Code noch ein Fehler ist.
Die Farbe 34 (Helltürkis) wird irgendwie nicht aufgeführt.
Ich habe es auch mit anderen Farben ausprobiert. Es wird nur die erste genannte Farbe n i c h t ausgegeben!
Warum ?
Gruß
Lemmi

AW: Zellefarbe in Register übernehmen
07.09.2007 21:47:58
Josef
Hallo Lemmi,
schlampigkeitsfehler Meinerseits.
in beiden Prozeduren muss es
lngColor = Application.Match(Zelle.Value, vValues, 0) - 1

lauten. Das -1 hatte ich vergessen.
Gruß Sepp

Anzeige
AW: Zellefarbe in Register übernehmen
08.09.2007 20:41:32
Lemmi
Hallo Sepp,
alles o. k. !
Gruß
Lemmi

Links zu Excel-Dialogen

InputBox

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige