Option Explicit
Sub Transp()
Dim wksSum As Excel.Worksheet
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
Call JoinRecordsets(wks, wksSum, bCopyHeader)
bCopyHeader = False
End If
Next
Call ExpandRecordsets(wksSum)
Call MsgBox("Fertig.", vbInformation)
End Sub
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")
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
For i = LBound(vntField) To UBound(vntField)
Set rng = Worksheet.Rows(1).Find(vntField(i), LookIn:=xlValues, LookAt:=xlWhole)
rng.Offset(, 1).Resize(, 2).EntireColumn.Insert xlShiftToRight
rng.Offset(, 1).Value = "Industry of " & rng.Text
rng.Offset(, 2).Value = "Country of " & rng.Text
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
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
rng.Offset(, 1).Value = "-"
rng.Offset(, 2).Value = "-"
End If
Set rng = rng.Offset(1)
Wend
Next
End Sub
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
Set rngS = rngS.Offset(1).Resize(rngS.Rows.Count - 1)
Set rngD = Destination.UsedRange
Set rngD = rngD.Rows(rngD.Rows.Count).Offset(1)
Call rngS.Copy(rngD)
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
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