Jede zweite Zeile aus Wookbook A in ein anderes WB

Sub Referenzkurve_Klicken() 'Daten aus .csv kopieren und einfügen 'ACHTUNG: ggf. Pfad ändern Workbooks.Open Filename:="Z:\Probe\Referenz.csv" Range("A1:K1").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy ActiveWindow.Close Sheets("Kurve").Select Range("A1").Select ActiveSheet.Paste 'Jede zweite Zeile löschen Dim i As Integer For i = 3 To 5000 Step 1 Sheets("Kurve").Rows(i).Delete Next 'Daten in Spalten separieren Worksheets("Kurve").Activate Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _ Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _ TrailingMinusNumbers:=True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Referenzkurve_Klicken() 'Daten aus .csv kopieren und einfügen 'ACHTUNG: ggf. Pfad ändern Dim arrIn, arrOut(), i As Long, j As Long, n As Long Workbooks.Open Filename:="Z:\Probe\Referenz.csv" arrIn = Range("A1").CurrentRegion ActiveWorkbook.Close ReDim arrOut(1 To UBound(arrIn), 1 To 11) For j = 1 To 12 arrOut(1, j) = arrIn(1, j) arrOut(2, j) = arrIn(2, j) Next n = 2 For i = 3 To UBound(arrIn) Step 2 n = n + 1 For j = 1 To 11 arrOut(n, j) = arrIn(i, j) Next j Next i With Sheets("Kurve") .Cells(1, 1).Resize(n, 11) = arrOut 'Daten in Spalten separieren .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _ Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _ TrailingMinusNumbers:=True End With End Sub

Sub Referenzkurve_Klicken() 'Daten aus .csv kopieren und einfügen 'ACHTUNG: ggf. Pfad ändern Dim arrIn, arrOut(), i As Long, j As Long, n As Long Workbooks.Open Filename:="Z:\Probe\Referenz.csv" arrIn = Range("A1").CurrentRegion ActiveWorkbook.Close ReDim arrOut(1 To UBound(arrIn), 1 To UBound(arrIn, 2)) For j = 1 To UBound(arrIn, 2) arrOut(1, j) = arrIn(1, j) arrOut(2, j) = arrIn(2, j) Next n = 2 For i = 3 To UBound(arrIn) Step 2 n = n + 1 For j = 1 To UBound(arrIn, 2) arrOut(n, j) = arrIn(i, j) Next j Next i With Sheets("Kurve") .Cells(1, 1).Resize(n, UBound(arrOut, 2)) = arrOut 'Daten in Spalten separieren .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _ Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _ TrailingMinusNumbers:=True End With End Sub

Hi
jede zweite Zeile zu kopieren wird auch nicht viel schneller gehen, als jede zweite Zeile zu löschen.
das Problem ist, dass in beiden Fällen jede Zeile einzeln bearbeitet werden muss, und das kostet zeit.
um das ganze zu beschleunigen, sollest du so vorgehen:
1. alles in einem Schritt kopieren
2. per Formel in einer Hilfsspalte die zu löschenden Zeilen kennzeichnen, bspw die zu löschenden mit 1 und die die stehenbleiben müssen mit dem Text ""
3. die Liste nach der Hilfsspalte sortieren.
4. alle Zellen mit Zahl und der Option "ganze Zeile löschen"
das ist schneller, weil jetzt nicht jede Zeile einzeln, sondern alle Zellen gemeinsam gelöscht werden können.
der schritt 4 sieht als Code so aus:

Columns(...).SpecialCells(xlcelltypeformulas, 1).entirerow.Delete

es würde auch ohne das Sortieren funktionieren, aber das bringt in diesem Fall die Geschwindigkeit.
Ab Excel 2007 kann man auch ohne sortieren schnell löschen.
hier zu kennezichnet man in der Hilfsspalte die Zeilen die gelöscht werden sollen per formel mit 0 und die die stehen bleiben müssen mit der Zeilennummer.
In die Überschriftenzeile der Hilfsspalte schreibt man eben falls die 0 und wendet dann das Duplikate-entfernen mit der Hilfsspalte als Kriterium und der Option "keine Überschrift" an.
sieht als code so aus:

With Sheets("Kurve").Usedrange
with .columns(.Columns.count + 1)
.FormulaR1C1 = "=If(IsOdd(Row()),0,Row())"
.Cells(1, 1).value = 0
.EntireRow.Removeduplicates
.ClearContents
end with
End with

Gruß Daniel

Beliebteste Forumthreads (12 Monate)

Jede zweite Zeile aus Wookbook A in ein anderes WB

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Jede zweite Zeile aus Wookbook A in ein anderes WB

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread