Option Explicit

Sub Transp()
   
  Dim wksSum        As Excel.Worksheet 'Zusammenfassung aller Daten
  Dim wks           As Excel.Worksheet
  Dim bCopyHeader   As Boolean
  
  Set wksSum = Tabelle3
  
  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 = "Industry of " & rng.Text
    rng.Offset(, 2).Value = "Country of " & rng.Text
     
    '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)
  
  Const C_SPREADSHEET$ = "Spreadsheet"
  
  If Header Then
    Source.Rows(1).Copy Destination.Rows(1)
    With Destination.UsedRange.Rows(1).End(xlToRight)
      .Copy
      .Offset(, 1).PasteSpecial xlPasteFormats
      .Offset(, 1).Value = C_SPREADSHEET
      Application.CutCopyMode = False
    End With
  End If
  
  Dim rngS As Excel.Range
  Dim rngD As Excel.Range
  Dim rngSS 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... ;)
  
  Set rngSS = Destination.Rows(1).Find(C_SPREADSHEET, LookIn:=xlValues, LookAt:=xlWhole)
  If Not rngSS Is Nothing Then
    Set rngSS = Intersect(rngD.EntireRow, rngSS.EntireColumn)
    rngSS.Value = Source.Name
  End If
  
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 bFlag(3) Or Len(Trim$(tmp)) = 0 _
          Then Exit Function
        
        If bFlag(1) Then
          bFlag(2) = True
          Sector = Trim$(tmp)
          tmp = ""
        Else
          tmp = tmp & "-"
        End If
          
      Case Else
        tmp = tmp & Mid$(str, i, 1)
          
    End Select
  Next
    
  Extract = True
    
End Function