Excel; Finde: farbige Zelle in Spalte | Ergebnis: Inhalt in entsprechender Zeile?

Hallo alle zusammen,
ich hoffe der Titel konnte schon das Grundproblem erläutern.
Ich habe einen Projektplan in Excel, welcher in der ersten, und dritten Spalte Informationen zu einer bestimmten Aufgabe enthält. In den folgenden Spalten sind aufsteigend Kalender Wochen angegeben. In den Zellen die sich mit bestimmten Kalenderwochen schneiden, in denen die Aufgabe erfüllt werden soll, sind dann in verschiedenen Farben gefüllt.

Ang.1 Ang.2 Ang.3 KW1 KW2 KW3 KW4 KW5 KW6 usw.
Aufg1.Kom1............[Farbe]
Aufg2............Kom2................[Farbe]

Ich hoffe das macht es etwas verständlicher. Ich will nun aus diesen Grunddaten jeweils eine Wochen-ToDo-Liste machen. Also für eine bestimmte Spalte die Zellen mit Füllung finden, und dann die dazugehörigen Inhalte der Zellen aus Spalte 1-3 ausgeben. Das am einfachsten in einem neuen Tabellenblatt. Ich denke grundsätzlich bekomme ich den Code dazu hin. Mir fehlt hauptächlich eine Methode die farbigen Zellen zu finden. Und brauche eure Hilfe.

Ich freue mich schon auf eure Vorschläge
Grüßle
Alex

 

@Alex - Hier ein Vorschlag mit VBA

Rechtsklick auf Tab "Projektplan" > Code anzeigen >>> im Editor den Code eingeben >

Code:

Option Explicit

Sub Wochenplan()
Dim actSpalte
Dim actZeile
Dim toDoZeile
Dim toDo1
Dim toDo2
Dim toDo3
                    '5 = erste Ausgabezeile im WochenToDo
toDoZeile = [COLOR="Red"]5[/COLOR]
                    'geht in Zeile2 der gewählten Woche
    actSpalte = ActiveCell.Column
    Cells([COLOR="red"]2[/COLOR], actSpalte).Select
Do
                    'wenn am Spaltenende > fertig
    If ActiveCell.Value = "[COLOR="red"]---[/COLOR]" Then Exit Do
    actSpalte = ActiveCell.Column
    actZeile = ActiveCell.Row
                    'wenn Zellfarbe anders als Weiss
    If ActiveCell.Interior.Color <> RGB(255, 255, 255) Then
                    'liest Spalten 1-3 aus
        toDo1 = Cells(actZeile, 1).Value
        toDo2 = Cells(actZeile, 2).Value
        toDo3 = Cells(actZeile, 3).Value
                    'geht auf Blatt WochenToDo und füllt aus
        Sheets("[COLOR="red"]]WochenToDo[/COLOR]").Activate
        ActiveSheet.Cells(toDoZeile, 1).Value = toDo1
        ActiveSheet.Cells(toDoZeile, 2).Value = toDo2
        ActiveSheet.Cells(toDoZeile, 3).Value = toDo3
                    'nächste WochenToDo-Zeile eine runter
        toDoZeile = toDoZeile + 1
                    'geht auf Projektplan, 1 Zeile tiefer
        Sheets("[COLOR="red"]Projektplan[/COLOR]").Activate
        Cells(actZeile + 1, actSpalte).Select
    Else
                    'wenn Zellfarbe = weiss > eine tiefer
        ActiveCell.Offset(1, 0).Select
    End If
                    'nächster Durchgang...
Loop

End Sub

Bedingungen:

- Alles rot markierte Deinem Workbook anpassen

- Blatt "WochenToDo" muss geöffnet sein (allenfalls vorhandene Einträge würden überschrieben)

- Im "Projektplan" unter den Spalten KWx jeweils eine Stopzelle eingeben, ich habe "---" hingeschrieben

- Zur Sicherheit weiter unten, wo niemand hinschaut, eine ganze Zeile, etwas über die letzte Nutzspalte hinaus, mit "---"-Zellen füllen. Wenn das obere "---" fehlt, oder das Makro mit einer falsch gesetzten Aktivzelle startet, rattert er sonst die ganzen 65'000+ Zeilen durch...

Funktion:

- Zelle in der KWx-Spalte aktivieren, irgendwo oberhalb "---"

- Makro laufen lassen (über Makrostart, Button...)

- In jeder nicht-weissen Zelle werden die Spalten 1-3 ausgelesen und nach "WochenToDo" geschrieben.

Gruss Urs

 

Hi Alex,

Code:

Sub wochenplan()
    Dim inSpalte As Integer
    Dim inZeile As Integer
    Dim inZeile2 As Integer
    Dim raWoche As Range
    inZeile2 = 2
    With Worksheets("Projektplan")
        Set raWoche = .Rows(1).Find("KW2", lookat:=xlWhole)
        If Not raWoche Is Nothing Then
            For inZeile = 2 To IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
                If .Cells(inZeile, raWoche.Column).Interior.ColorIndex <> xlNone Then
                    .Range("A" & inZeile & ":C" & inZeile).Copy Worksheets("Wochenplan").Cells(inZeile2, 1)
                    inZeile2 = inZeile2 + 1
                End If
            Next inZeile
        End If
    End With
End Sub

Du musst nur noch eine Suche einbauen, wie du ermittelst, nach welcher KW gesucht werden soll und diese Variable anstelle von "KW2" in die Findanweisung schreiben.

 

Kleiner Formatierungsfehler im Code >

die Zeile >
Sheets("]WochenToDo").Activate

muss natürlich heissen >
Sheets("WochenToDo").Activate

Gruss Urs