|
Hallo Sebastian,
zu Antwort 1: Da kann ich leider nichts zu sagen, schon gar nicht ohne Mustermappe...
zu Antwort 2: Du solltest die Störfaktoren wie die ständige Bildschirmaktualisierung abschalten, dann geht es auch schneller.
Hier mal ein etwas angepasster Code zur evtl. weiteren Verwendung (ungetestet):
PS: Bei .Rows(i).Copy Destination:=tbl1.Rows(a) bin ich mir unsicher, ob's funktioniert, da ich mit diesen Listobjects nch nicht gearbeitet habe.
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
47
48
49 |
|
Option Explicit
Sub Zusammenfassung()
Dim i, a, b As Integer
Dim tbl1, tbl2 As ListObject
Dim loLetzte As Integer
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
.Rows(i).Copy Destination:=tbl1.Rows(a)
' .Rows(i).Copy Destination:=Worksheets("xxx").Range(tbl1).Rows(a)
Case "yyy": b = b + 1
.Rows(i).Copy Destination:=tbl2.Rows(b)
' .Rows(i).Copy Destination:=Worksheets("yyy").Range(tbl2).Rows(b)
End Select
Next i
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
|
_________
viele Grüße
Karl-Heinz
|