Zusammenfassung von allem was wir bisher hatten + dem Neuen.

Der Abschnitt in dem du deine Arbeitsblätter, die vom DBExport kommen, auswählst, müsstest du evtl. noch anpassen. Gestartet wird der ganze Rassel mit Aufruf von Transp().

Ich hatte leider für den gesamten Ablauf nicht mehr alle Dateiquellen zur Hand, konnte daher abschließend nicht komplett testen. Ich hoffe es funktioniert trotzdem.

Option Explicit

Private Type tRecord
  Name    As String
  Value   As Variant
  Format  As String
End Type
 
Private Type tRecordset
  Record() As tRecord
  Count As Long
End Type

Sub Transp()
  
  Dim wksDBExport   As Excel.Worksheet
  Dim wksSum        As Excel.Worksheet 'Zusammenfassung aller Daten
  Dim wks           As Excel.Worksheet
  Dim bCopyHeader   As Boolean
  Dim bNotAll       As Boolean
  Dim n&, nt&, result&
  
  Set wksSum = Tabelle3
  
  bCopyHeader = True
  
  For Each wksDBExport In ThisWorkbook.Worksheets 'oder wie auch immer diese ausgewählt werden
    
    'neues Arbeitsblatt
    Set wks = Worksheets.Add(Before:=Worksheets(1))
    wks.Name = wksDBExport.Name & "_t"
    
    'DBExport-Daten aufbereiten (u.a. transponieren)
    result = TranspRecordsets(wksDBExport, wks, n)
    If result = -1 Then bNotAll = True
    
    nt = nt + n 'Gesamtanzahl kopierter Datensätze
    
    'aufbereitete Daten der Zusammenfassung hinzufügen
    Call JoinRecordsets(wks, wksSum, bCopyHeader)
    
    bCopyHeader = False 'einmal Kopfzeile genügt ;)
  Next
  
  'Datensätze erweitern (bestimmte Spalten werden aufgeteilt)
  Call ExpandRecordsets(wksSum)
  
  'Benutzer über das Ergebnis informieren
  If Not bNotAll Then
     
    If nt <> 1 Then
      Call MsgBox("Es wurden " & nt & " Datensätze kopiert.", vbInformation)
    Else
      Call MsgBox("Es wurde 1 Datensatz kopiert.", vbInformation)
    End If
     
  Else
    Call MsgBox("Nicht alle Datensätze konnten verarbeitet werden." & vbNewLine & " -> verarbeitet: " & nt, _
                vbExclamation)
  End If
  
End Sub

Private Function TranspRecordsets(Source As Excel.Worksheet, Destination As Excel.Worksheet, Count As Long) As Long
   
  Destination.UsedRange.Clear
   
  Application.ScreenUpdating = False
   
  Dim rng As Excel.Range
  Dim rs  As tRecordset
  Dim result&, rid&, n&, i&
  Dim bCopyHeader As Boolean
  Dim bExit As Boolean
   
  bCopyHeader = True
  rid = 2
   
  Set rng = Source.Range("B2")
   
  While Not bExit
     
    result = GetNextRecordset(rng, rs)
     
    If result = 1 Then
       
      For i = 1 To rs.Count
         
        'einmalig Kopfzeile ausfüllen
        If rid > 1 And bCopyHeader Then
          With Destination.Cells(rid - 1, i)
            .Font.Bold = True
            .Value = rs.Record(i).Name
            .WrapText = False
          End With
        End If
         
        'Daten in die Zeile schreiben
        With Destination.Cells(rid, i)
          .NumberFormat = rs.Record(i).Format
          .Value = rs.Record(i).Value
          .WrapText = False
        End With
         
      Next
       
      bCopyHeader = False
       
      rid = rid + 1
      n = n + 1
       
    Else
      bExit = True
    End If
     
  Wend
   
  Application.ScreenUpdating = True
  
  TranspRecordsets = result
  Count = n
  
End Function
 
Private Sub ExpandRecordsets(Worksheet As Excel.Worksheet)
  
  Dim rng As Excel.Range
  Dim strOrganisation$, strCountry$, strSector$
  Dim vntField()
  Dim i As Long
  
  vntField = Array("Target", "Acquiror", "Vendor")
  
  'Prüfung ob die Felder alle vorhanden sind
  For i = LBound(vntField) To UBound(vntField)
    Set rng = Worksheet.Rows(1).Find(vntField(i), LookIn:=xlValues, LookAt:=xlWhole)
    If rng Is Nothing Then
      Call MsgBox("Spalte mit Titel '" & vntField(i) & "' in Arbeitsblatt '" & Worksheet.Name & "' nicht gefunden.", _
                  vbCritical, _
                  "Daten-Erweiterung abgebrochen")
      Exit Sub
    End If
  Next
  
  'Spalten hinzufügen und befüllen
  For i = LBound(vntField) To UBound(vntField)
    
    'Spalte suchen
    Set rng = Worksheet.Rows(1).Find(vntField(i), LookIn:=xlValues, LookAt:=xlWhole)
    
    'zusätzliche Spalten einfügen und Betiteln
    rng.Offset(, 1).Resize(, 2).EntireColumn.Insert xlShiftToRight
    rng.Offset(, 1).Value = rng.Text & " Industry"
    rng.Offset(, 2).Value = rng.Text & " Country"
    
    'Zeile für Zeile Daten in dieser Spalte schreiben...
    Set rng = rng.Offset(1)
    While rng.Text <> ""
      If rng.Text <> "" And rng.Text <> "-" Then
        If Extract(rng.Text, strOrganisation, strCountry, strSector) Then
          rng.Value = strOrganisation
          rng.Offset(, 1).Value = strSector
          rng.Offset(, 2).Value = strCountry
        Else
        'FEHLER: Ausdruck konnte nicht ausgewertet werden
          rng.Resize(, 3).Font.Color = vbRed
          rng.Resize(, 3).Font.Bold = True
          rng.Offset(, 1).Value = CVErr(xlErrNA)
          rng.Offset(, 2).Value = CVErr(xlErrNA)
        End If
      Else
      'kein Ausdruck zum auswerten
        rng.Offset(, 1).Value = "-"
        rng.Offset(, 2).Value = "-"
      End If
      Set rng = rng.Offset(1)
    Wend
    
  Next
  
End Sub

Private Function GetNextRecordset(Ref As Excel.Range, Recordset As tRecordset) As Long
   
  'eine Leerzeile überspringen ist erlaubt
  If Len(Trim(Ref.Cells(1).Text)) = 0 Then
    Set Ref = Ref.Offset(RowOffset:=1)
  End If
   
  'Anfang Datensatz (DS)?
  If Len(Trim(Ref.Cells(1).Text)) > 0 Then
     
    Dim c           As Excel.Range
    Dim rs          As tRecordset
    Dim bRecord     As Boolean
    Dim bAdd2Prev   As Boolean
     
    bRecord = Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0
    While bRecord
       
      If rs.Count > 0 And Len(Trim(Ref.Cells(1).Text)) > 0 Then
      'PROBLEM:
      'Angeblich neuer DS erkannt, ohne das der
      'aktuelle DS mit Leerzeile abgeschlossen wurde
         
        rs.Count = 0
        Erase rs.Record
         
        GetNextRecordset = -1
        Exit Function
         
      'Name mit nur einem Wert?
      ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
              And Not Ref.Offset(ColumnOffset:=1).MergeCells Then
        bAdd2Prev = False
         
      'Name mit mehreren Werten?
      ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
              And Ref.Offset(ColumnOffset:=1).MergeCells Then
        bAdd2Prev = True
         
      Else
        bRecord = False
      End If
       
      If bRecord Then
         
        rs.Count = rs.Count + 1
        ReDim Preserve rs.Record(1 To rs.Count)
         
        With rs.Record(rs.Count)
          .Name = Ref.Offset(ColumnOffset:=1).Cells(1).Text
           
          If Not bAdd2Prev Then
            .Value = Ref.Offset(ColumnOffset:=2).Cells(1).Value
          Else
            For Each c In Ref.Offset(ColumnOffset:=2).Resize(Ref.Offset(ColumnOffset:=1).MergeArea.Rows.Count, 1).Cells
              .Value = .Value & IIf(Not IsEmpty(.Value), vbNewLine, "") & c.Value
            Next
          End If
           
          .Format = Ref.Offset(ColumnOffset:=2).Cells(1).NumberFormat
        End With
         
        'nächster Eintrag
        Set Ref = Ref.Offset(RowOffset:=1)
      End If
       
    Wend
     
    Recordset = rs
     
    rs.Count = 0
    Erase rs.Record
     
    'Rückgabe
    GetNextRecordset = 1
  Else
    'Rückgabe
    'GetNextRecordset = 0
  End If
   
End Function

Private Sub JoinRecordsets(Source As Excel.Worksheet, Destination As Excel.Worksheet, Optional Header As Boolean)
  
  If Header Then Source.UsedRange.Rows(1).Copy Destination.Rows(1)

  Dim rngS As Excel.Range
  Dim rngD As Excel.Range
  
  Set rngD = Destination.UsedRange
  Set rngD = rngD.Rows(rngD.Rows.Count).Offset(1) 'erste leere Zeile
  
  Set rngS = Source.UsedRange
  Set rngS = rngS.Offset(1).Resize(rngS.Rows.Count - 1) 'zu kopierende Datensätze
  
  Call rngS.Copy(rngD) 'kopieren, wär hätte es geahnt... ;)
  
End Sub

'////////////////
'IN : Str
'OUT: Organisation, Country, Sector
'RET: True/False
Function Extract(Str As String, Organisation As String, Country As String, Sector As String) As Boolean
   
  Dim bFlag(1 To 3) As Boolean
  Dim tmp$
  Dim i&
   
  For i = 1 To Len(Str)
     
    Select Case Mid$(Str, i, 1)
      Case "("
        If bFlag(1) Then Exit Function
        bFlag(1) = True
        Organisation = Trim$(tmp)
        tmp = ""
         
      Case ")"
        If bFlag(3) Or Not (bFlag(1) And bFlag(2)) Or Len(Trim$(tmp)) = 0 Then Exit Function
        bFlag(3) = True
        Country = Trim$(tmp)
        tmp = ""
        Exit For
         
      Case "-"
        If bFlag(2) Or Not bFlag(1) Or bFlag(3) Or Len(Trim$(tmp)) = 0 Then Exit Function
        bFlag(2) = True
        Sector = Trim$(tmp)
        tmp = ""
         
      Case Else
        tmp = tmp & Mid$(Str, i, 1)
         
    End Select
  Next
   
  Extract = True
   
End Function