|
Hallo Sebastian,
das hatte ich befürchtet, dass das nicht funktioniert, ist aber nicht schlimm.
Das Ausschalten der Bildschirmaktualisierung hätte aber was bringen müssen, denn es werden zwischenzeitlich weder Neuaufbau der Seite noch Berechnungen durchgeführt, die Zeit kosten.
Das Rausspringen nach leeren Feldern ist in dem Code nicht zu erkennen. In der Schleife meiner SELECT CASE-Variante erfolgt keine vorzeitige Beendigung.
Auch die letzte Zeile wird korrekt ermittelt.
PS: Falls Du nur Text übernehmen musst (weiß ich ja jetzt nicht) kannst Du das auch ohne Copy/Paste machen. Dann sollte es noch schneller gehen.
Hier noch mal ein (ungetestet) Update.
Und bezugnehmend auf Ulrichs Beitrag solltest Du auch auf eine korrekte Dimensionierung der Variablen achten.
Das habe ich jetzt mal nachgezogen (hatte mich eben nur auf den Inhalt konzentriert). Für Zeilenangaben bietet sich Long an.
Code:
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46 |
|
Option Explicit
Sub Zusammenfassung()
Dim i As Long, a As Long, b As Long
Dim tbl1 As ListObject, tbl2 As ListObject
Set tbl1 = Worksheets("xxx").ListObjects("Tabelle13")
Set tbl2 = Worksheets("yyy").ListObjects("Tabelle14")
If tbl1.ListRows.Count >= 1 Then
tbl1.DataBodyRange.Delete
End If
If tbl2.ListRows.Count >= 1 Then
tbl2.DataBodyRange.Delete
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With Worksheets("GSV").ListObjects("Tabelle1").DataBodyRange
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
Select Case .Cells(i, 2)
Case "xxx": a = a + 1
Worksheets("xxx").Range(tbl1).Rows(a).Value = .Rows(i).Value
Case "yyy": b = b + 1
Worksheets("yyy").Range(tbl2).Rows(b).Value = .Rows(i).Value
End Select
Next i
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
|
_________
viele Grüße
Karl-Heinz
|