Ach so, die Aufgaben sind voneinander getrennt. ;)

Läuft es nun damit?

Option Explicit

Sub Transp()
   
  Dim wksSum        As Excel.Worksheet 'Zusammenfassung aller Daten
  Dim wks           As Excel.Worksheet
  Dim bCopyHeader   As Boolean
  
  Set wksSum = Tabelle4
  
  bCopyHeader = True
  
  wksSum.UsedRange.Clear
  
  For Each wks In ThisWorkbook.Worksheets
    If wks.Name Like "CB_*" _
    Or wks.Name Like "DOM_*" _
    Then
      'Daten der Zusammenfassung hinzufügen
      Call JoinRecordsets(wks, wksSum, bCopyHeader)
      bCopyHeader = False 'einmal Kopfzeile genügt ;)
    End If
  Next
  
  'Datensätze erweitern (bestimmte Spalten werden aufgeteilt)
  Call ExpandRecordsets(wksSum)
  
  Call MsgBox("Fertig.", vbInformation)
  
End Sub

'////////////////////////////////////////////
'// Erweitert die Daten um zusätzliche Spalten
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") 'die "aufzudröselnden" Spalten
  
  '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

'////////////////////////////////////////////
'// Fügt Datensätze zu einem zusammen
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 rngS = Source.UsedRange
  If rngS.Rows.Count = 1 Then Exit Sub                  'wenn es nichts zum kopieren gibt -> Exit
  Set rngS = rngS.Offset(1).Resize(rngS.Rows.Count - 1) 'zu kopierende Datensätze
     
  Set rngD = Destination.UsedRange
  Set rngD = rngD.Rows(rngD.Rows.Count).Offset(1) 'erste leere Zeile
  
  Call rngS.Copy(rngD) 'kopieren, wär hätte es geahnt... ;)
  
End Sub
 
'////////////////
'// Extrahiert Informationen aus einer Zeichenkette
'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