' HIER EINE MULTILINE-VERSION
' NOCH NICHT BERÜCKSICHTIGT: evtl. "free.." in Zeile

Sub Swap_Coordinate() 'v1.0 coded by UEZ
    Dim RegExsult As String
    Dim allMatches As Object
    Dim innerMatches As Object
    Dim RegEx As Object 'New VBScript_RegExp_55.RegExp 'Tools -> References -> Microsoft VBScript Regular Expression 5.5
    Set RegEx = CreateObject("VBScript.RegExp")
    Dim iMultiLine As Integer
    Dim iCurrent As Integer
    RegExsult = ""
    iCurrent = 0

    RegEx.Pattern = "(\n)"
    RegEx.Global = True
    RegEx.IgnoreCase = True
    Set allMatches = RegEx.Execute(ActiveCell.Text)
    iMultiLine = allMatches.Count

    If iMultiLine = 0 Then
        RegEx.Pattern = "(.*) to (.*)"
        Set allMatches = RegEx.Execute(ActiveCell.Text)
        If allMatches.Count > 0 Then
            RegExsult = allMatches.Item(0).subMatches.Item(1) & " to " & allMatches.Item(0).subMatches.Item(0) & " " & allMatches.Item(0).subMatches.Item(2)
            ActiveCell.Value = RegExsult
        End If
    Else
        RegEx.Pattern = "(.*)\n?"
        Set allMatches = RegEx.Execute(ActiveCell.Text)
        Do While iCurrent <= iMultiLine
            RegEx.Pattern = "(.*) to (.*)"  ' wenn in MultiLine noch "free..." steht musst du das Pattern entsprechend anpassen
            Set innerMatches = RegEx.Execute(allMatches.Item(iCurrent))
            If RegExsult <> "" Then
                RegExsult = RegExsult & Chr(13) & Chr(10)
            End If
            RegExsult = RegExsult & innerMatches.Item(0).subMatches.Item(1) & " to " & innerMatches.Item(0).subMatches.Item(0)
            iCurrent = iCurrent + 1
        Loop
        ActiveCell.Value = RegExsult
    End If

    Set allMatches = Nothing
    Set RegEx = Nothing
End Sub