Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
832to836
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
832to836
832to836
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zelleninhalte bestimmte Farbe kopieren?

Zelleninhalte bestimmte Farbe kopieren?
30.12.2006 23:50:13
Selma
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

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zelleninhalte bestimmte Farbe kopieren?
31.12.2006 13:41:47
Beni
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

AW: Zelleninhalte bestimmte Farbe kopieren?
01.01.2007 03:24:12
Selma
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
Anzeige
AW: Zelleninhalte bestimmte Farbe kopieren?
01.01.2007 13:17:14
Beni
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

Anzeige
AW: Zelleninhalte bestimmte Farbe kopieren?
01.01.2007 17:04:44
Erich
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!
Anzeige
AW: Zelleninhalte bestimmte Farbe kopieren?
01.01.2007 17:10:57
Erich
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
AW: gefärbte Zellen kopieren - Korrektur
01.01.2007 17:33:49
Erich
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
Anzeige
AW: gefärbte Zellen kopieren - Korrektur
02.01.2007 02:41:59
Selma
Vielen Dank Beni,
vielen Dank Erich
LG
Selma

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige