Datensätze aufspalten

Public Function LetzteZeile(wks As Worksheet) As Long On Error Resume Next LetzteZeile = wks.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious). _ Row If Err Then LetzteZeile = 0 End If On Error GoTo 0 End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo iceer,
hier ein optimiertes Excel-Makro.
Laufzeit auf meinem Notebook unter Windows Vista/Excel2010 ca. 4 Sekunden bei ca. 30000 Datenzeilen
LG
Franz

Sub kopieren_Neu()
Dim Zeile As Long
Dim SpalteX As Long
Dim Zeile_L As Long
Dim StatusCalc As Long
Dim wks_1 As Worksheet
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wks_1 = Sheets("Tabelle1")
'Altdaten löschen
Sheets("Tabelle2").UsedRange.ClearContents
Sheets("Tabelle3").UsedRange.ClearContents
With wks_1
SpalteX = LetzteSpalte(wks_1) + 1 'Spalte für Hilfswert
Zeile_L = LetzteZeile(wks_1) 'letzte Zeile mit Daten
'Hilfswert WAHR in Hilfspalte eintragen für alle Zeilen, _
die nach "Tabelle2" kopiert werden sollen
For Zeile = 1 To Zeile_L
If Sheets("Tabelle1").Cells(Zeile, 1).Text  "" Then
If Not .Cells(Zeile, 2).Text Like "*asd*" Then
.Range(.Cells(Zeile, SpalteX), .Cells(Zeile + 18, SpalteX)).Value = True
Zeile = Zeile + 18
End If
End If
Next Zeile
'Zeilen nach Tabelle2 kopieren
With .Range(.Cells(1, SpalteX), .Cells(Zeile_L, SpalteX))
.SpecialCells(Type:=xlCellTypeConstants, Value:=xlLogical).EntireRow _
.Copy Destination:=Worksheets("Tabelle2").Range("A1")
End With
'Spalten rechts von Spalte E löschen
With Worksheets("Tabelle2")
.Range(.Cells(1, 6), .Cells(Zeile_L, SpalteX)).EntireColumn.Delete
End With
'Zeilen nach Tabelle3 kopieren
With .Range(.Cells(1, SpalteX), .Cells(Zeile_L, SpalteX))
.SpecialCells(Type:=xlCellTypeBlanks).EntireRow _
.Copy Destination:=Worksheets("Tabelle3").Range("A1")
End With
'Spalten rechts von Spalte E löschen
With Worksheets("Tabelle3")
.Range(.Cells(1, 6), .Cells(Zeile_L, SpalteX)).EntireColumn.Delete
End With
'Hilfsspalte wieder löschen
.Cells(1, SpalteX).EntireColumn.Delete
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
MsgBox "Fertig!"
End Sub
Public Function LetzteZeile(wks As Worksheet) As Long
On Error Resume Next
LetzteZeile = wks.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).  _
_
Row
If Err Then
LetzteZeile = 0
End If
On Error GoTo 0
End Function
Public Function LetzteSpalte(wks As Worksheet) As Long
On Error Resume Next
LetzteSpalte = wks.Cells.Find(After:=wks.Cells(1, 1), What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
If Err Then
LetzteSpalte = 0
End If
On Error GoTo 0
End Function

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread