rows = 1
For Each item In arrTabelle
Set rs = C.Execute("(.....)" + item)
strErgebnis = rs.Fields("(...)").Value
For Each item2 In AllTables(strErgebnis)
ActiveSheet.Range("A" & rows).Value = item
ActiveSheet.Range("B" & rows).Value = item2
rows = rows + 1
Next item2
Next item
End With
End Sub
Function AllTables(strInput As String) As Variant
Dim rMatch As Object
Dim s As String
Dim arrayMatches()
Dim i As Long
With New RegExp
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = " .(....)"
If .test(strInput) Then
For Each rMatch In .Execute(strInput)
ReDim Preserve arrayMatches(i)
arrayMatches(i) = rMatch.Value
i = i + 1
Next
End If
End With
AllTablesMatches = Join(arrayMatches, " ")
End Function