VBA farbige Zellen übertragen

Question

Hallo Excelfreunde,
ich möchte von einem Tabellenblatt (A4:H5000) nur die farbigen Zellen (Interior.ColorIndex = 3) in ein andere Tabelle (A3) übertragen.
Wie müßte das Makro aussehen?
Ich hoffe ihr habt eine Idee dazu.

Gruß
fedjo

Answer 1

Hallo fedjo,

folgender Code überträgt die Zelladressen der roten Zellen aus Tabelle1 in Tabelle2 ab A3 abwärts.

Option Explicit

Sub farbig()
Dim rngC As Range, intZ As Integer
intZ = 3
For Each rngC In Range("A4:H5000")
If rngC.Interior.ColorIndex = 3 Then
Worksheets("Tabelle2").Cells(intZ, 1).Value = rngC.Address
intZ = intZ + 1
End If
Next
End Sub

Feedback wäre nett
Gruss Rainer
_____________________
Windows 7 Ultimate (x64)
Office 2007 Ultimate
Office 2003 Professional

Answer 2

Hi Fedjo,

wie sollen alle Zellen in einer einzigen aufgelistet werden?

Bis später,
Karin

Answer 3

Hallo Rainer,
danke für die schnelle Antwort.
Ich hatte ganz vergessen, das nur die Werte der farbigen Zellen übertragen werden sollen.

Gruß
fedjo

Answer 4

Hallo Karin,
alle Zellen einer Zeile soll auch so nur mit den Werten übertragen werden, ohne Leerzeilen.

Gruß
fedjo

Answer 5

Hi Fedjo,

die Inhalte aller Zellen einer Zeile, wenn in irgend einer Zelle davon die Füllfarbe Rot ist, sollen zeilenweise untereinander aufgelistet werden? Du musst das schon ein wenig genauer beschreiben, denn niemand sieht deine Arbeitsmappe und niemand außer dir weiß, was genau du erreichen willst.

Bis später,
Karin

Answer 6

Hallo Karin,

die Inhalte aller Zellen einer Zeile, wenn in irgend einer Zelle davon die Füllfarbe Rot ist, sollen zeilenweise untereinander aufgelistet werden?

Das ist genau das wie ich es beschreiben wollte.
Es ist dann auch die ganze Zeile immer z.B (A4:H4) mit roter Füllfarbe hinterlegt.

Gruß
fedjo

Answer 7

Hi Fedjo,

also nicht nur 1 Zelle sondern alle 7 Zellen müssen Rot sein.

Sub Uebertragen()
Dim lngZeile As Long
Dim lngZeile2 As Long
Dim bytSpalte As Byte
Dim bytSpalte2 As Byte
lngZeile2 = 3
With Worksheets("Tabelle1")
Application.ScreenUpdating = False
For lngZeile = 4 To 5000
For bytSpalte = 1 To 7
If .Cells(lngZeile, bytSpalte).Interior.ColorIndex = 3 Then bytSpalte2 = bytSpalte2 + 1
Next bytSpalte
If bytSpalte2 = 7 Then
Worksheets("Tabelle2").Cells(lngZeile2, 1) = .Cells(lngZeile, 1)
Worksheets("Tabelle2").Cells(lngZeile2, 2) = .Cells(lngZeile, 2)
Worksheets("Tabelle2").Cells(lngZeile2, 3) = .Cells(lngZeile, 3)
Worksheets("Tabelle2").Cells(lngZeile2, 4) = .Cells(lngZeile, 4)
lngZeile2 = lngZeile2 + 1
End If
bytSpalte2 = 0
Next lngZeile
Application.ScreenUpdating = True
End With
End Sub

Bis später,
Karin

Answer 8

Hi Karin,
dein Makro erfüllt nach einer kleinen Anpassung genau meine Anforderungen.

Danke für deine Unterstützung.
Schönes Wochenende.

Gruß
fedjo