AW: makro: jede zweite zeile kopieren will nich
24.11.2007 04:55:00
Daniel
HI
hier 2 Beispiele, wie du sowas lösen kannst
Makro 1 über Autofiler
Makro 2 mit Formeln
beide Methoden sind schleifenfrei und daher sehr schnell und auch für sehr grosse Datenmengen geeignet.
Sub Makro1()
Dim lngLetzteZeile As Long
Dim lngSpalte As Long
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Set wksZiel = Sheets(1)
Set wksQuelle = Sheets(2)
With wksQuelle
lngSpalte = 2
lngLetzteZeile = .Cells(65536, lngSpalte).End(xlUp).Row
.Range("A:B").Insert
.Range("A1").Resize(lngLetzteZeile).FormulaR1C1 = "=Row()"
.Range("B1").Resize(lngLetzteZeile).FormulaR1C1 = "=MOD(ROW(),2)"
.Range("A1").Resize(lngLetzteZeile, 2).Formula = Range("A1").Resize(lngLetzteZeile, 2). _
Value
.Range("A1").CurrentRegion.Sort , key1:=.Range("B2"), order1:=xlAscending, header:=xlYes
.Range("A1").AutoFilter field:=2, Criteria1:="=0"
.Columns(lngSpalte + 2).SpecialCells(xlCellTypeVisible).Copy
wksZiel.Cells(1, lngSpalte).PasteSpecial xlPasteValues
.Range("A1").AutoFilter
.Range("A1").CurrentRegion.Sort , key1:=.Range("A2"), order1:=xlAscending, header:=xlYes
.Range("A:B").Delete
End With
End Sub
Sub Makro2()
Dim lngLetzteZeile As Long
Dim lngSpalte As Long
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Set wksZiel = Sheets(1)
Set wksQuelle = Sheets(2)
lngSpalte = 2
lngLetzteZeile = wksQuelle.Cells(65536, lngSpalte).End(xlUp).Row
With wksZiel.Cells(2, lngSpalte).Resize(lngLetzteZeile / 2, 1)
.FormulaR1C1 = "=INDEX('" & wksQuelle.Name & "'!C,ROW()*2-2)"
.Formula = .Value
End With
End Sub
Gruß, Daniel