|
Hallo Sebastian,
zu 1.
Da nehmen wir jetzt nur noch Blätter die nicht GSV heißen und ein ListObjekt enthalten
zu 2.
Die Suchbegriffe müssen nicht überienstimmen sondern der Text muss im Blattnamen enthalten sein oder der Blattname im Text.
Da solltest Du Deine Blattname noch anpassen.
Alle nicht gefundenen Texte werden jetzt im Blatt "Nicht Gefunden" abgelegt (bitte noch anlegen). Da kannst Du gleich sehen, was nicht aufgeteilt wurde.
Wenn dann immer was noch nicht passt, kannst Du Einzelfälle ja noch mit SELECT CASE abfangen...
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
63
64
65
66
67
68
69
70 |
|
Option Explicit
Option Compare Text
Sub Gesamt()
Dim i As Long, j As Long
Dim sArrBlatt() As String, sArrList() 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)
sArrBlatt(i) = .Name
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 sArrBlatt(j) Like "*" & .Cells(i, 2).Value & "*" Or _
.Cells(i, 2).Value Like "*" & sArrBlatt(j) & "*" 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
|
_________
viele Grüße
Karl-Heinz
|