Hallo!

Ich arbeite schon wieder/immer noch an diesem Projekt. Ich habe es ein wenig angepasst und erweitert und es läuft sehr gut - vielen Dank nochmal an volti!

Nun sitze ich gerade daran, den Code um die Funktion zu erweitern, dass zusätzlich auch Zellformatierungen mitkopiert werden. Der einzige copy-Prozess passiert ja durch .value = .value. Kann man dazu noch bspw. Zellfüllfarbe mit einfügen?

Hier nochmal der Code in Gänze:

 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
  

' 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,
Sebastian