Excel: Farben aus Zellen übernehmen

Dieses Thema Excel: Farben aus Zellen übernehmen im Forum "Microsoft Office Suite" wurde erstellt von falcon30, 10. Juni 2005.

Thema: Excel: Farben aus Zellen übernehmen Hallo, ich habe folgendes Problem: Ich habe eine Datei mit ca. 40 Arbeitsblättern. In Arbeitsblatt Projekte sind...

  1. Hallo,

    ich habe folgendes Problem:

    Ich habe eine Datei mit ca. 40 Arbeitsblättern.
    In Arbeitsblatt Projekte sind in der Spalte B ab Zeile 77 ca. 50 Projektnamen.
    Die restlichen 39 Arbeitsblätter heißen genauso wie die Projektnamen aus B.
    Diese 39 Arbeitsblätter haben in den Zellen C12, F12, k12, c25, g25 Farben (grün, gelb, rot)
    Diese farben möchte ich jetzt übernehmen, und zwar in den Arbeitsblatt Projekte.
    Dabei soll die Zuordung über Spalte B und den Arbeitsblätternamen erfolgen.
    Die Farben sollen in die Entspechenden Projekte übernommen werden. Die übernommenen Farben sollen ab Spalte AF eingefügt werden. Also soll z.B. für das erste Projekt C12 in AF77, F12 in AG77, K12 in AH77 usw. übernommen werden.

    Vielen Dank!!

    Grüße
    falcon30
     
  2. Hallo falcon30,

    bei den Projektberichten ist es üblich, die Farben der Ampel über die->bedingte Formatierung' zu realisieren - deswegen auch nur 3 Farben, weil mehr geht mit bedingter Formatierung nicht.

    Diese Farbe gehört leider nicht zum Zellinhalt und läßt sich nicht auslesen. Da müßte man die Formel der 3 bedingten Formatierungen kennen, um mit einem Makro die Auswertung nachvollziehen und dann im Hauptblatt die Farben entsprechend setzen zu können.

    Gruß Matjes :)
     
  3. Hallo,


    hier ist die bedingte Formatierung (Ich glaube es ist von dir):

    Private Sub Worksheet_Change(ByVal Target As Range)

    Dim RaBereich1 As Range, RaZelle1 As Range
    -> Bereich der Wirksamkeit
    Set RaBereich1 = Range(B11:X35)
    ' noch mehr Bereiche
    ' Set RaBereich = Union(Range(C7:I26), Range(L7:R26), Range(U7:AA26), Range(AD7:AJ26))

    For Each RaZelle1 In Range(Target.Address)
    If Not Intersect(RaZelle1, RaBereich1) Is Nothing Then
    With RaZelle1
    Select Case Target.Value
    Case rot
    Target.Interior.ColorIndex = 3
    Case gelb
    Target.Interior.ColorIndex = 27
    Case grün
    Target.Interior.ColorIndex = 4
    Case nicht relevant
    Target.Font.ColorIndex = 20
    Target.Interior.ColorIndex = 1
    Case -
    Target.Interior.ColorIndex = 48
    Case Else
    Target.Interior.ColorIndex = 2

    End Select
    End With
    End If
    Next RaZelle1

    Set RaBereich1 = Nothing

    Const c_Bereich = C14:C22
    Const c_ZelleAusgabe = B12:D12
    Const c_FarbeRot = rot
    Const c_FarbeRotIndex = 3
    Const c_FarbeGelb = gelb
    Const c_FarbeGelbIndex = 6
    Const c_FarbeGruen = grün
    Const c_FarbeGruenIndex = 4

    Dim Zelle As Range, a As Long, z As Long, c As Long
    Dim l_ZeileAnf As Long, l_ZeileEnd As Long
    Dim l_SpalteAnf As Long, l_SpalteEnd As Long
    Dim l_FarbIndex As Long, s_Farbe As String

    ->Anfangs- und End-Zeile/Spalte des zu überwachenden Bereiches
    l_ZeileAnf = Range(c_Bereich).Row
    l_ZeileEnd = Range(c_Bereich).Row + Range(c_Bereich).Rows.Count - 1
    l_SpalteAnf = Range(c_Bereich).Column
    l_SpalteEnd = Range(c_Bereich).Column + Range(c_Bereich).Columns.Count - 1


    ->Zellen des geänderte Bereiches untersuchen
    For Each Zelle In Target
    ->schauen, ob die geänderte Zelle im überwachten Bereich liegt
    If Zelle.Row >= l_ZeileAnf And Zelle.Row <= l_ZeileEnd And _
    Zelle.Column >= l_SpalteAnf And Zelle.Column <= l_SpalteEnd Then
    ->-> Zelle im überwachten Bereich

    ->Bereich auf Farben untersuchen
    ->Reihenfolge Rot, Gelb, Gruen
    For a = 1 To 3
    ->gesuchte Farbe setzen
    If a = 1 Then
    l_FarbIndex = c_FarbeRotIndex
    s_Farbe = c_FarbeRot
    ElseIf a = 2 Then
    l_FarbIndex = c_FarbeGelbIndex
    s_Farbe = c_FarbeGelb
    ElseIf a = 3 Then
    l_FarbIndex = c_FarbeGruenIndex
    s_Farbe = c_FarbeGruen
    End If

    For z = l_ZeileAnf To l_ZeileEnd
    For c = l_SpalteAnf To l_SpalteEnd
    If Cells(z, c).Value = s_Farbe Then
    ->in einer Zelle im überwachten Bereich steht die Farbe
    ->-> Ausgabezelle -> Farbe
    Range(c_ZelleAusgabe).Interior.ColorIndex = l_FarbIndex
    Exit Sub->Farbe gesetzt -> Ende
    End If
    Next
    Next
    Next
    ->Da keine Farbe gesetzt wurde -> farblos setzen
    Range(c_ZelleAusgabe).Interior.ColorIndex = xlColorIndexNone

    End If
    Next


    Grüße
    falcon30
     
  4. Hiiiiiiilllllllllllllllllllllfffffffffffffffffffffffeeeeeeeeeeeeeeee!!
     
  5. Hallo falcon,

    bist du vom Stuhl gefallen  ;D

    Der Makro unten hilft dir wieder auf  :D Ist allerdings kein Automatismus sondern muß von Hand gestartet werden.

    Viel Spaß beim Farbe pinseln  ;D

    Gruß matjes :

    ps: korrigiert auf Spalte C nach falcon's Anforderung und Bug korrigiert

    Code:
    Option Explicit
    'Ich habe eine Datei mit ca. 40 Arbeitsblättern.
    'In Arbeitsblatt Projekte sind in der Spalte C ab Zeile 77 ca. 50 Projektnamen.
    'Die restlichen 39 Arbeitsblätter heißen genauso wie die Projektnamen aus B.
    'Diese 39 Arbeitsblätter haben in den Zellen C12, F12, k12, c25, g25 Farben (grün, gelb, rot)
    'Diese farben möchte ich jetzt übernehmen, und zwar in den Arbeitsblatt Projekte.
    'Dabei soll die Zuordung über Spalte C und den Arbeitsblätternamen erfolgen.
    'Die Farben sollen in die Entspechenden Projekte übernommen werden.
    'Die übernommenen Farben sollen ab Spalte AF eingefügt werden.
    'Also soll z.B. für das erste Projekt C12 in AF77, F12 in AG77, K12 in AH77 usw. übernommen werden.
    
    Sub ProjektFarbeSammeln()
      
      Const c_BlattName = Projekte
      Const c_SP_ProjNamen As String = C
      Const c_ZAnf_ProjNamen As Long = 77->erstes Zeile mit Projekt
      Const c_SPAmpel = AF
      Const c_Ampel1 = C12
      Const c_Ampel2 = F12
      Const c_Ampel3 = K12
      Const c_Ampel4 = C25
      Const c_Ampel5 = G25
      
      Dim wb As Workbook, wsProj As Worksheet, ws As Worksheet, s_tmp As String
      Dim l_SPAmpel As Long, l_Zeileproj As Long
      Set wb = ActiveWorkbook
      
     ->Hauptblatt setzen
      On Error Resume Next
      Set ws = wb.Worksheets(c_BlattName)
      If Err.Number <> 0 Then
        MsgBox (Blatt  & c_BlattName &  konnte nicht aktiviert werden.)
        GoTo Aufraeumen
      End If
      l_SPAmpel = Columns(c_SPAmpel).Column
      l_Zeileproj = c_ZAnf_ProjNamen
      Do
       ->Leere Zelle Bxx -> Ende
        If ws.Range(c_SP_ProjNamen & l_Zeileproj).Value =  Then GoTo Aufraeumen
        s_tmp = ws.Range(c_SP_ProjNamen & l_Zeileproj).Value
        Set wsProj = wb.Worksheets(s_tmp)
        If Err.Number = 0 Then
         ->Farben holen
          ws.Cells(l_Zeileproj, l_SPAmpel).Interior.ColorIndex = _
                    wsProj.Range(c_Ampel1).Interior.ColorIndex
          ws.Cells(l_Zeileproj, l_SPAmpel + 1).Interior.ColorIndex = _
                        wsProj.Range(c_Ampel2).Interior.ColorIndex
          ws.Cells(l_Zeileproj, l_SPAmpel + 2).Interior.ColorIndex = _
                        wsProj.Range(c_Ampel3).Interior.ColorIndex
          ws.Cells(l_Zeileproj, l_SPAmpel + 3).Interior.ColorIndex = _
                        wsProj.Range(c_Ampel4).Interior.ColorIndex
          ws.Cells(l_Zeileproj, l_SPAmpel + 4).Interior.ColorIndex = _
                        wsProj.Range(c_Ampel5).Interior.ColorIndex
        Else
          MsgBox ( _
            Projekt-Blatt  & s_tmp & _
             konnte nicht gelesen werden. & vbLf & _
            Kontrollieren Sie auf dem Haupblatt  & _
            ws.Range(c_SP_ProjNamen & l_Zeileproj).Address)
          Err.Clear
        End If
        l_Zeileproj = l_Zeileproj + 1
      Loop
      
    Aufraeumen:
      Set wb = Nothing: Set ws = Nothing: Set wsProj = Nothing
      On Error GoTo 0
    End Sub
     
  6. Hallo Matjes,

    leider bekomme ich folgende Fehlermeldung:

    Projekt-Blatt * konnte nicht gelesen werden.

    Die Arbeitsblätter werden nicht erkannt?

    Woran kann es liegen?

    Grüße
    falcon30
     
  7. Hallo falcon,

    hab die Meldungsausgabe im Makro (siehe oben) angepasst, so daß jetzt die Zelle mit ausgegeben wird, bei dem er keinen passenden Blattnamen findet.

    Gruß Matjes :)
     
  8. Hallo Matjes,

    es wird kein einziges Tabellenblatt erkannt.

    Es wird für jeden eintrag in spalte C die dazugehörige Arbeitsmappe nicht erkannt oder gefunden.

    Grüße
    falcon
     
  9. Hallo Matjes,

    dein Makro funktioniert!!
    Ich habe einfach mal eine Exceldatei, ohne irgendeine Formatierung, angelegt. Hier tuts.


    Es muss irgendwie an meinen Arbeitsblättern liegen.

    Wie kann ich überprüfen woran es liegt.

    Grüße
    Sahin Duygun
     
  10. Hallo falcon30,

    ich hab den Makro noch etwas modifiziert (siehe oben) bzgl. der Formatierung in B77 ff. Vielleicht hilft das ja schon.

    Die Formatierung auf dem Hauptblatt B77... ist Text ? Welches Format haben die Zellen ?

    Gruß Matjes :)
     
Die Seite wird geladen...

Excel: Farben aus Zellen übernehmen - Ähnliche Themen

Forum Datum
Excel 2003 Mitarbeiterfarben Microsoft Office Suite 25. Apr. 2007
excel 2003; berechnete daten in farben umwandeln Microsoft Office Suite 16. Nov. 2006
Excel: Zellenfarben Microsoft Office Suite 19. Juli 2006
Namen der Excelfarben Windows XP Forum 25. Juni 2006
Excel bedingte Formatierung mit Farben Microsoft Office Suite 26. Juni 2005