|
Hallo Sebastian,
habe mich ein wenig mit Deiner Datei beschäftigt. Die LetzteZeile-Ermittlung läuft hier dann schon anders als angenommen. Vielleicht liegt Dein Problem daran.
Deinen ganzen bisherigen Code könnte man mit geschickter Array-Verwendung auf den u.a. Code reduzieren. Also alle Module entfernen und nur den u.a. Code verwenden.
Bitte teste mal, ob alle Eventualitäten abgedeckt sind. Falls alles klappt soweit, kannst Du später einfach neue Tabellen einfügen, ohne überhaupt am Code etwas anpassen zu müssen.
Falls noch was nicht klappt, melde Dich einfach noch mal:
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
50
51
52
53
54
55
56
57
58
59
60
61
62 |
|
Option Explicit
Sub Gesamt()
Dim i As Long, j As Long
Dim sArrBlatt() As String, sArrList() As String, iZeile() As Long
' Speed ein
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
' Einlesen der Tabellenblattnamen und Listobjektnamen in Array
For i = 1 To ThisWorkbook.Worksheets.Count
ReDim Preserve sArrBlatt(i)
ReDim Preserve sArrList(i)
sArrBlatt(i) = ThisWorkbook.Worksheets(i).Name
sArrList(i) = ThisWorkbook.Worksheets(i).ListObjects(1)
Next i
ReDim iZeile(UBound(sArrBlatt))
' Löschen der Datenbereiche aller Tabellen
For i = 1 To UBound(iZeile)
If Not sArrBlatt(i) Like "GSV" Then
With ThisWorkbook.Worksheets(sArrBlatt(i)).ListObjects(sArrList(i))
If .ListRows.Count >= 1 Then .DataBodyRange.Delete
End With
End If
Next i
' Übertragen der Daten
With ThisWorkbook.Worksheets("GSV").ListObjects("Tabelle1").DataBodyRange
For i = 1 To .Rows.Count
For j = 1 To UBound(iZeile)
If sArrBlatt(j) Like "*" & .Cells(i, 2).Value & "*" Then
iZeile(j) = iZeile(j) + 1
ThisWorkbook.Worksheets(sArrBlatt(j)).Range(sArrList(j)).Rows(iZeile(j)).Value = .Rows(i).Value
Exit For
End If
Next j
Next i
End With
' Formatieren der Spaltenbreite aller Tabellen
On Error Resume Next
For i = 1 To UBound(iZeile)
If Not sArrBlatt(i) Like "GSV" Then
Worksheets(sArrBlatt(i)).ListObjects(sArrList(1)).Columns.AutoFit
End If
Next i
' Speed aus
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Fertig!", vbInformation, "Datenübertragung"
End Sub
|
_________
viele Grüße
Karl-Heinz
|