Herbers Excel-Forum - das Archiv

Bewerten Sie hier bitte das Excel-Portal

Zelleninhalte bestimmte Farbe kopieren?

Zelleninhalte bestimmte Farbe kopieren? von Selma vom 30.12.2006 23:50:13

AW: Zelleninhalte bestimmte Farbe kopieren? - von Beni am 31.12.2006 13:41:47
- AW: Zelleninhalte bestimmte Farbe kopieren? - von Selma am 01.01.2007 03:24:12
  - AW: Zelleninhalte bestimmte Farbe kopieren? - von Beni am 01.01.2007 13:17:14
  - AW: Zelleninhalte bestimmte Farbe kopieren? - von Erich G. am 01.01.2007 17:04:44
  - AW: Zelleninhalte bestimmte Farbe kopieren? - von Erich G. am 01.01.2007 17:10:57
  - AW: gefärbte Zellen kopieren - Korrektur - von Erich G. am 01.01.2007 17:33:49
    - AW: gefärbte Zellen kopieren - Korrektur - von Selma am 02.01.2007 02:41:59

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

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

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

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

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!

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

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

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

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