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
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
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
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! Range(Cells(1, 1), Cells(lngB, 1)).Copy .Cells(lngZ, 1)
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
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.