Herbers Excel-Forum - das Archiv

Zelleninhalte bestimmte Farbe kopieren?

Bild

Betrifft: Zelleninhalte bestimmte Farbe kopieren?
von: Selma

Geschrieben am: 30.12.2006 23:50:13
Hallo Leute,
ich möchte gern nur die Zelleninhalte (aus der Spalte A) die mit der rote Hintergrundfarbe dargestellt sind in Arbeitsblatt "Export" in Spalte A kopieren.
Wie mache ich das per VBA?
Vielen Dank im Voraus...
Liebe Grüße
SELMA
Bild

Betrifft: AW: Zelleninhalte bestimmte Farbe kopieren?
von: Beni

Geschrieben am: 31.12.2006 13:41:47
Hallo Selma,
kopiere diesen Code in ein Modul und starte es aus der Datentabelle laufen mit Alt+F8
Gruss Beni
Sub Zelleninhalte_bestimmte_Farbe_kopieren()
With Sheets("Export")
For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex = 3 Then
lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(i, 1).Copy .Cells(lz, 1)
End If
Next i
End With
End Sub

Bild

Betrifft: AW: Zelleninhalte bestimmte Farbe kopieren?
von: Selma
Geschrieben am: 01.01.2007 03:24:12
Hallo Beni,
die Datentabelle hat über 40000 Zeilen. Das Makro habe ich gestartet und ist noch nicht fertig. Es läuft schon über eine halbe Stunde.
LG
Selma
Bild

Betrifft: AW: Zelleninhalte bestimmte Farbe kopieren?
von: Beni

Geschrieben am: 01.01.2007 13:17:14
Hallo Selma,
wenn die Screenaktualisierung ausgeschaltet ist, gehts schneller.
Gruss Beni
Sub Zelleninhalte_bestimmte_Farbe_kopieren()
Dim i, lz As Long
Application.ScreenUpdating = False ' schaltet die Screenaktualisierung aus
With Sheets("Export")
For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex = 3 Then
lz = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lz, 1) = Cells(i, 1) ' ohne Formatübertrag
End If
Next i
End With
Application.ScreenUpdating = True ' schaltet die Screenaktualisierung ein
End Sub

Bild

Betrifft: AW: Zelleninhalte bestimmte Farbe kopieren?
von: Erich G.

Geschrieben am: 01.01.2007 17:04:44
Hallo Selma,
so sollte es noch einen Tick schneller gehen:
Option Explicit
Sub KopiereRotA()
Dim lngQ As Long, intS As Integer, rngF As Range, lngB As Long, lngZ As Long
Dim Calc As XlCalculation
Calc = Application.Calculation: Beschleuniger xlCalculationManual
lngQ = Cells(Rows.Count, 1).End(xlUp).Row
intS = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(1, intS + 1).Select
ActiveWorkbook.Names.Add Name:="Farb", RefersToR1C1:= _
"=IF(GET.CELL(63,Tabelle1!RC[-10])=3,0,1)"
Range(Cells(1, intS + 1), Cells(lngQ, intS + 1)).Formula = "=Farb"
Range(Cells(1, intS + 2), Cells(lngQ, intS + 2)).Formula = "=ROW()"
ActiveSheet.Calculate
Range(Cells(1, intS + 2), Cells(lngQ, intS + 2)) = _
Range(Cells(1, intS + 2), Cells(lngQ, intS + 2)).Value
Cells(1, 1).Sort Key1:=Cells(1, intS + 1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom
Set rngF = Columns(intS + 1).Find(What:=1, After:=Cells(lngQ, intS + 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, SearchFormat:=False)
If rngF Is Nothing Then lngB = lngQ Else lngB = rngF.Row - 1
If lngB > 0 Then
With Sheets("Export")
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
If IsEmpty(.Cells(lngZ, 1)) Then lngZ = 1
Range(Cells(1, 1), Cells(lngB, intS)).Copy Sheets("Export").Cells(lngZ, 1)
If lngB < lngQ Then _
Cells(1, 1).Sort Key1:=Cells(1, intS + 2), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom
End With
End If
Range(Columns(intS + 1), Columns(intS + 2)).Delete
ActiveWorkbook.Names("Farb").Delete
Beschleuniger Calc
End Sub
'   Beschleuniger _______ Parameter: Calc-Status ______ gi/12.03.2006
'Aufruf:
'   Dim Calc As XlCalculation
'   Calc = Application.Calculation: Beschleuniger xlCalculationManual
'   ....Code....
'   Beschleuniger Calc
Sub Beschleuniger(StatCal As XlCalculation)
Application.Calculation = StatCal
Application.ScreenUpdating = (StatCal <> xlCalculationManual)
End Sub
Rückmeldung wäre nett! - Erich aus Kamp-Lintfort wünscht allen einen guten Start ins neue Jahr!
Bild

Betrifft: AW: Zelleninhalte bestimmte Farbe kopieren?
von: Erich G.

Geschrieben am: 01.01.2007 17:10:57
Hallo Selma,
habe gerade gemerkt, dass mein Makro viel zu viel tut - es sollten ja nur die Zellen aus Spalte A kopiert werden.
Ersetze bitte die Zeile mit dem Copy durch
         Range(Cells(1, 1), Cells(lngB, 1)).Copy .Cells(lngZ, 1)
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Bild

Betrifft: AW: gefärbte Zellen kopieren - Korrektur
von: Erich G.

Geschrieben am: 01.01.2007 17:33:49
Hallo Selma,
sorry, da war noch ein Fehler drin (bei der Namendefinition). Also noch mal:
Option Explicit
Sub KopiereRotA()
Dim lngQ As Long, intS As Integer, rngF As Range, lngB As Long, lngZ As Long
Dim Calc As XlCalculation
Calc = Application.Calculation: Beschleuniger xlCalculationManual
lngQ = Cells(Rows.Count, 1).End(xlUp).Row
intS = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(1, intS + 1).Select
ActiveWorkbook.Names.Add Name:="Farb", RefersToR1C1:= _
"=IF(GET.CELL(63,Tabelle1!RC[-" & intS & "])=3,0,1)"
Range(Cells(1, intS + 1), Cells(lngQ, intS + 1)).Formula = "=Farb"
Range(Cells(1, intS + 2), Cells(lngQ, intS + 2)).Formula = "=ROW()"
ActiveSheet.Calculate
Range(Cells(1, intS + 2), Cells(lngQ, intS + 2)) = _
Range(Cells(1, intS + 2), Cells(lngQ, intS + 2)).Value
Cells(1, 1).Sort Key1:=Cells(1, intS + 1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom
Set rngF = Columns(intS + 1).Find(What:=1, After:=Cells(lngQ, intS + 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, SearchFormat:=False)
If rngF Is Nothing Then lngB = lngQ Else lngB = rngF.Row - 1
If lngB > 0 Then
With Sheets("Export")
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
If IsEmpty(.Cells(lngZ, 1)) Then lngZ = 1
'        Range(Cells(1, 1), Cells(lngB, intS)).Copy .Cells(lngZ, 1)  ' ganze Zeilen
'        Range(Cells(1, 1), Cells(lngB, 1)).Copy .Cells(lngZ, 1)     ' nur Spalte A
'        Range(.Cells(lngZ, 1), .Cells(lngZ + lngB - 1, intS)) = _
Range(Cells(1, 1), Cells(lngB, intS)).Value              ' Werte, ganze Zeilen
Range(.Cells(lngZ, 1), .Cells(lngZ + lngB - 1, 1)) = _
Range(Cells(1, 1), Cells(lngB, 1)).Value                 ' Werte, nur Spalte A
If lngB < lngQ Then _
Cells(1, 1).Sort Key1:=Cells(1, intS + 2), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom
End With
End If
Range(Columns(intS + 1), Columns(intS + 2)).Delete
ActiveWorkbook.Names("Farb").Delete
Beschleuniger Calc
End Sub
'   Beschleuniger _______ Parameter: Calc-Status ______ gi/12.03.2006
'Aufruf:
'   Dim Calc As XlCalculation
'   Calc = Application.Calculation: Beschleuniger xlCalculationManual
'   ....Code....
'   Beschleuniger Calc
Sub Beschleuniger(StatCal As XlCalculation)
Application.Calculation = StatCal
Application.ScreenUpdating = (StatCal <> xlCalculationManual)
End Sub
Unten kannst du dir aussuchen, ob du komplette Zellen oder nur Werte bzw. ganze Zeilen oder nur Spalte A kopieren willst.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Bild

Betrifft: AW: gefärbte Zellen kopieren - Korrektur
von: Selma
Geschrieben am: 02.01.2007 02:41:59
Vielen Dank Beni,
vielen Dank Erich
LG
Selma
 Bild
Excel-Beispiele zum Thema "Zelleninhalte bestimmte Farbe kopieren?"
Befindet sich die aktive Zelle in einem bestimmten Bereich? Werte eins bestimmten Monats summieren
Werte 1 und 0 in einem bestimmten Verhältnis zufällig anordnen Alle Links zu einer bestimmten Arbeitsmappe löschen
Anzahl eines bestimmten Wochentages im Monat Alle Dateien ab einem bestimmten Datum listen
Daten eines bestimmten Jahres filtern Word mit bestimmtem Dokument starten
Bestimmte Anzahl von Zeichen zulassen Zeilen löschen, wenn in bestimmten Spalten keine Werte stehen