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
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
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
sArrList(i) = .ListObjects(1)
i = i + 1
End If
End With
Next j
ReDim iZeile(UBound(sArrBlatt))
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
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
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox iAnz & " Zeilen wurden verarbeitet", vbInformation, "Datenübertragung"
End Sub