Option Explicit
Public Sub ExtractParamsFromClipboard()
Dim rngParams As Excel.Range
Dim strData As String
Set rngParams = Selection
strData = GetClipboardTextData()
If strData = "" Then
Call MsgBox("Keine Daten in der Zwischenablage gefunden.", vbExclamation)
Exit Sub
End If
If rngParams.Cells.Count = 1 Or rngParams.Columns.Count > 1 Then
Call MsgBox("Aktuelle Auswahl verletzt Kriterien:" _
& vbNewLine & "Max-Spalten: 1, Min-Zellen: 2", _
vbExclamation)
Exit Sub
End If
Dim vntParam As Variant
Dim dicParams As Object
Set dicParams = CreateObject("Scripting.Dictionary")
For Each vntParam In rngParams.Cells
dicParams(vntParam) = Empty
Next
Call ExtractParams(strData, dicParams)
For Each vntParam In rngParams.Cells
vntParam.Offset(0, 1).Value = dicParams(vntParam.Value)
Next
Call MsgBox("Extraktion fertsch.", vbInformation)
End Sub
Private Sub ExtractParams(Expr As String, ByRef ParamDictionary As Object)
Dim objMatch As Object
Dim strPattern As String
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
.MultiLine = True
strPattern = Join(ParamDictionary.Keys(), vbNullChar)
.Pattern = "([-[\]{}()*+?.,\\^$|#\s])"
strPattern = .Replace(strPattern, "\$1")
strPattern = Replace$(strPattern, vbNullChar, "|")
strPattern = "(" & strPattern & ")\s+([^\r\n]+)"
.Pattern = strPattern
For Each objMatch In .Execute(Expr)
ParamDictionary(objMatch.Submatches(0)) = objMatch.Submatches(1)
Next
End With
End Sub
Public Function GetClipboardTextData() As String
On Error Resume Next
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Call .GetFromClipboard
GetClipboardTextData = .GetText()
End With
End Function