Excel: Farben aus Zellen übernehmen

falcon30 · 10.06.2005

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

Matjes · 10.06.2005

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

falcon30 · 10.06.2005

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

12
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

falcon30 · 12.06.2005

Hiiiiiiilllllllllllllllllllllfffffffffffffffffffffffeeeeeeeeeeeeeeee!!

Matjes · 13.06.2005

Hallo falcon,

bist du vom Stuhl gefallen ;D

Der Makro unten hilft dir wieder auf

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 &lt;> 0 Then
    MsgBox (Blatt  &amp; c_BlattName &amp;  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 &amp; l_Zeileproj).Value =  Then GoTo Aufraeumen
    s_tmp = ws.Range(c_SP_ProjNamen &amp; 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  &amp; s_tmp &amp; _
         konnte nicht gelesen werden. &amp; vbLf &amp; _
        Kontrollieren Sie auf dem Haupblatt  &amp; _
        ws.Range(c_SP_ProjNamen &amp; 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

falcon30 · 13.06.2005

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

Matjes · 13.06.2005

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

falcon30 · 13.06.2005

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

falcon30 · 13.06.2005

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

Matjes · 13.06.2005

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

falcon30 · 13.06.2005

Hi,

tut immer noch nicht obwohl die Spalte C als Text formatiert ist.

Gibt es die möglichkeit eine Datei anzuhängen?

Grüße
falcon30

Matjes · 13.06.2005

Hallo falcon30,

wieso eigentlich immer Spalte C

In dem Thread sprachst du immer von B77 und folgende. Hat sich das geändert ? Wenn ja, könntest Du das unter c_SP_ProjNamen anpassen.

Gruß Matjes

falcon30 · 13.06.2005

Hallo Matjes,

sorry!!

Spalte B ist jetzt Spalte C.

Hatte ich aber im Makro immer geändert gehabt.

Grüße
Sahin

falcon30 · 13.06.2005

Hi,

ich habe gerade das ganze noch einmal in einer anderen Datei getestet.

Beim ersten duchlauf tut es.
Wenn ich in den Arbeitsblättern was ändere und dann das Makro noch einmal starte, werden die Änderungen nicht übernommen.

Grüße
falcon30

falcon30 · 13.06.2005

Hallo,

ich nehme meine Anwort 13 wieder zurück. Ich habe die falschen Felder angesprochen.

Aber in der Original-Datei funktioniert es immer noch nicht.

:-[ falcon30

falcon30 · 13.06.2005

Hallo,

ich habe jetzt herausgefunden warum das Makro nicht durchläuft, korrigieren kann ich es leider nicht.

Es sind nicht für alle Projekte die in Spalte C stehen auch Arbeitsmappen angelegt, d.h. es gibt mehr Projekte als Arbeitsmappen.
Wenn das Makro feststellt dass eine Arbeitsmappe nicht existiert, dann tut es so als würden alle folgenden Arbeitsmappen auch nicht existieren.

Grüße
falcon30

falcon30 · 13.06.2005

Hallo,

ich habe die Else Schleife mit Err.Clear ergänzt:

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->***ergänzt

Ob das richtig ist oder nicht, keine Ahnung, aber es funkioniert.

Cool was?

Meine erste richtige Zeile Code.

Grüße
falcon30

Matjes · 13.06.2005

Hi falcon30,

das ist ein Volltreffer

Habs korrigiert und auch auf Spalte C angepßt.

Cool was? Meine erste richtige Zeile Code

Einer Zeile folgen mehrere ;D Weiter so !

Gruß Matjes

Excel: Farben aus Zellen übernehmen

falcon30

Matjes

falcon30

falcon30

Matjes

falcon30

Matjes

falcon30

falcon30

Matjes

falcon30

Matjes

falcon30

falcon30

falcon30

falcon30

falcon30

Matjes

Excel: Farben aus Zellen übernehmen

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums