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
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
Set wks = Worksheets.Add(Before:=Worksheets(1))
wks.Name = wksDBExport.Name & "_t"
result = TranspRecordsets(wksDBExport, wks, n)
If result = -1 Then bNotAll = True
nt = nt + n
Call JoinRecordsets(wks, wksSum, bCopyHeader)
bCopyHeader = False
Next
Call ExpandRecordsets(wksSum)
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
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
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")
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 = rng.Text & " Industry"
rng.Offset(, 2).Value = rng.Text & " Country"
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 Function GetNextRecordset(Ref As Excel.Range, Recordset As tRecordset) As Long
If Len(Trim(Ref.Cells(1).Text)) = 0 Then
Set Ref = Ref.Offset(RowOffset:=1)
End If
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
rs.Count = 0
Erase rs.Record
GetNextRecordset = -1
Exit Function
ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
And Not Ref.Offset(ColumnOffset:=1).MergeCells Then
bAdd2Prev = False
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
Set Ref = Ref.Offset(RowOffset:=1)
End If
Wend
Recordset = rs
rs.Count = 0
Erase rs.Record
GetNextRecordset = 1
Else
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)
Set rngS = Source.UsedRange
Set rngS = rngS.Offset(1).Resize(rngS.Rows.Count - 1)
Call rngS.Copy(rngD)
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 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