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