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
63
64
65
66
67
68
69
70
71 |
|
Option Explicit
Option Compare Text
Sub Gesamt()
Dim i As Long, j As Long
Dim sArrBlatt() As String, sArrList() As String, sArrSuch() As String
Dim iNotfound As Long, iZeile() As Long, iAnz As Long
' Speed ein
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
' Einlesen der Tabellenblattnamen und Listobjektnamen in Array
For j = 1 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Worksheets(j)
If Not .Name Like "GSV" And .ListObjects.Count > 0 Then
ReDim Preserve sArrBlatt(i)
ReDim Preserve sArrList(i)
ReDim Preserve sArrSuch(i)
sArrBlatt(i) = .Name
sArrSuch(i) = .Name ' Oder z.B. von einem ein Feld =Range("A1").value
sArrList(i) = .ListObjects(1)
i = i + 1
End If
End With
Next j
ReDim iZeile(UBound(sArrBlatt))
' Löschen der Datenbereiche aller Tabellen
For j = 0 To UBound(iZeile)
With ThisWorkbook.Worksheets(sArrBlatt(j)).ListObjects(sArrList(j))
If .ListRows.Count >= 1 Then .DataBodyRange.Delete
End With
Next j
' Übertragen der Daten
With ThisWorkbook.Worksheets("GSV").ListObjects("Tabelle1").DataBodyRange
For i = 1 To .Rows.Count
For j = 0 To UBound(iZeile)
If sArrSuch(j) Like "*" & .Cells(i, 2).Value & "*" Then
iZeile(j) = iZeile(j) + 1: iAnz = iAnz + 1
ThisWorkbook.Worksheets(sArrBlatt(j)).Range(sArrList(j)).Rows(iZeile(j)).Value = .Rows(i).Value
Exit For
End If
Next j
If j > UBound(iZeile) Then
iNotfound = iNotfound + 1
ThisWorkbook.Worksheets("Nicht gefunden").Rows(iNotfound).Value = .Rows(i).Value
End If
Next i
End With
' Formatieren der Spaltenbreite aller Tabellen
On Error Resume Next
For j = 0 To UBound(iZeile)
Worksheets(sArrBlatt(j)).ListObjects(sArrList(1)).Columns.AutoFit
Next j
' Speed aus
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox iAnz & " Zeilen wurden verarbeitet", vbInformation, "Datenübertragung"
End Sub
|