Office: (Office 2007) Inhalte farbige Zellen in anderes Blatt kopieren, Excel07 und VBA

Ruby · 15. Februar 2010

Moin Moin,
ich bin im VBA noch recht neu und benötige dringend einen Anstoß, wie ich folgendes Problem umsetzen kann.

Die erste Zeile eines Zellenbereiches (ca.60 Spalten und 2000 Zeilen) soll nach einer bestimmten Zahl durchsucht werden; z.B.36. Diese Zahl wird in A1 vorgegeben.

Wenn die Zahl gefunden wurde, soll in der jeweiligen Spalte nach unten gegangen werden, um farbig markierte Zellen zu finden. ColorIndex =10.
Wenn die einzelne Zelle im Suchblatt gefunden wurde, soll der darin enthaltene Wert in ein Zielblatt übertragen werden. Die Position der Zellen im Suchblatt und im Zielblatt unterscheiden sich um eine bestimmte Anzahl Zeilen und Spalten. Z.B. Zelle N6 im Suchblatt soll im Zielblatt auf Zelle S12 zurückgeschrieben werden.

Es wäre toll, wenn jemand eine treffende Idee hat. Habe bisher leider nichts Passendes gefunden...
Danke in voraus,
Ruby

:)

jinx · 17. Februar 2010

Moin, Ruby,

als Ansatz:

Code:

Dim rngCell As Range
Dim rngArea As Range
Const clngRow As Long = 5

'Suche
With Range(Cells(clngRow, 1), Cells(clngRow, Columns.Count))
Set rngCell = .Find(Range("A1").Value, LookIn:=xlValues)
End With

'nur. wenn gefunden
If Not rngCell Is Nothing Then
'Bereich der Spalte aufbauen
With rngCell
Set rngArea = Range(Cells(.Row, .Column), Cells(Cells(.Row, .Column).End(xlDown).Row, .Column))
End With
Set rngCell = Nothing
'durchlaufen
For Each rngCell In rngArea
If rngCell.Interior.ColorIndex = 10 Then
With rngCell
'Umschreiben
Sheets("Zielblatt").Cells(.Row + 6, .Column + 5).Value = rngCell.Value
Exit For
End With
End If
Next rngCell
End If

Set rngArea = Nothing
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Blattnamen, Angabe erste Zeile für die Suche und den Abstand von Zeilen und Spalten bitte anpassen - ich bin von Festwerten in der ersten Zeile zum Suchen ausgegangen...

Ruby · 22. Februar 2010

Hallo jinx,
Sorry, das ich mich heut erst melde- war leider krank.
Mit der Lösung wird nur der gesuchte Wert aus A1 in das Zielblatt kopiert, leider nicht der Wert aus der gefärbte Zelle; und auch nur für den ersten Fundort des Wertes und nicht für alle anderen.
Habe versucht, die Schleifen zu erweitern und das Set rngCell = Nothing rausgenommen – klappt leider nicht...

Gruß Ruby

jinx · 22. Februar 2010

Moin, Ruby,

da es in meiner zur Prüfung erstellten Beispielmappe geklappt hat - wie wäre es mit einer Mappe von Dir als Anhang, wo es nicht so funktioniert, wie Du es erwartest (bitte dann auch mit dem von Dir verwendeten Code)?

Ruby · 22. Februar 2010

Hallo jinx,
vielen Dank! Vielleicht kannst Du ja das Kneul entwirren...

Gruß Ruby

jinx · 22. Februar 2010

Moin, ruby,

mein Code war auf Deinen Angaben aufgebaut, und ich muss mich fragen., was an der Aussage

(bitte dann auch mit dem von Dir verwendeten Code)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

unverständlich ist - meines Wissens ist xlsx das Format für die Speicherung von Mappen ohne jeglichen VBA-Code...

Es ist im Ausgangsposting nicht die Rede davon, dass der Suchbegriff mehrmals vorkommen kann - daher wurde auch nur ein Suchvorgang eingesetzt. Und die Vorgabe der Färbung mit ColorIndex 10 stammt von Dir - wenn Du allerdings in der Beispielmappe dann 46 verwendest, kann kein Makro der Welt mit festen Vorgaben eine Umschreibung durchführen.

Code gehört in ein Makro in einem allgemeinen Modul, Anpassungen wegen der Farben , Blattnamen etc. sind vorzunehmen:

Code:

Dim rngCell As Range
Dim rngArea As Range
Const clngRow As Long = 1
Const cstrZiel As String = "ziel"
Dim rngFound As Range
Dim sAddress As String
Const clngColorIndex As Long = 46

Set rngFound = ActiveSheet.Range(Cells(clngRow, 2), Cells(clngRow, Columns.Count)).Find( _
what:=Range("A1").Value, LookIn:=xlValues)
If rngFound Is Nothing Then
Beep
MsgBox prompt:="Suchbegriff nicht gefunden!"
Exit Sub
End If
sAddress = Range("A1").Address
With rngFound
Set rngArea = Range(Cells(.Row, .Column).Address, Cells(Cells(Rows.Count, .Column).End(xlUp).Row, .Column).Address)
End With
For Each rngCell In rngArea
If rngCell.Interior.ColorIndex = clngColorIndex Then
With rngCell
'Umschreiben
Sheets(cstrZiel).Cells(.Row + 6, .Column + 5).Value = rngCell.Value
End With
End If
Next rngCell

While ActiveCell.Address sAddress
Set rngFound = Cells.FindNext(After:=rngFound)
If rngFound.Address = sAddress Then Exit Sub
With rngFound
Set rngArea = Range(Cells(.Row, .Column), Cells(Cells(Rows.Count, .Column).End(xlUp).Row, .Column))
End With
For Each rngCell In rngArea
If rngCell.Interior.ColorIndex = clngColorIndex Then
With rngCell
'Umschreiben
Sheets(cstrZiel).Cells(.Row + 6, .Column + 5).Value = rngCell.Value
End With
End If
Next rngCell
Wend

Set rngArea = Nothing
Set rngFound = Nothing
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ruby · 22. Februar 2010

Hallo jinx,
Viiiielen Dank! Das war genau richtig! Alle Probleme gelöst!

Gruß Ruby

Office: (Office 2007) Inhalte farbige Zellen in anderes Blatt kopieren, Excel07 und VBA

Inhalte farbige Zellen in anderes Blatt kopieren, Excel07 und VBA

Inhalte farbige Zellen in anderes Blatt kopieren, Excel07 und VBA

Inhalte farbige Zellen in anderes Blatt kopieren, Excel07 und VBA

Inhalte farbige Zellen in anderes Blatt kopieren, Excel07 und VBA - Similar Threads - Inhalte farbige Zellen

Wert aus Inputbox in Textbox übernehmen ohne Inhalt zu löschen

Inhalt eines Hyperlink Feldes in ein Textfeld kopieren

SVerweis auch mit farbig formatierten Inhalten?

Inhalt von Farbigen Zellen Addieren

Wenn Zelle mit bestimmtem Inhalt dann andere Zelle farbig markieren

Zellen mit gleichem Inhalt farbig kennzeichnen.

Gleiche Inhalte abwechselnd farbig markieren