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
            If RegExsult <> "" Then
                RegExsult = RegExsult & Chr(13) & Chr(10)
            End If
            RegEx.Pattern = "(.*) to (.*)( free .*)"
            Set innerMatches = RegEx.Execute(allMatches.Item(iCurrent))
            If innerMatches.Count = 0 Then
                RegEx.Pattern = "(.*) to (.*)"
                Set innerMatches = RegEx.Execute(allMatches.Item(iCurrent))
                RegExsult = RegExsult & innerMatches.Item(0).subMatches.Item(1) & " to " & innerMatches.Item(0).subMatches.Item(0)
            Else
                RegExsult = RegExsult & innerMatches.Item(0).subMatches.Item(1) & " to " & innerMatches.Item(0).subMatches.Item(0) & innerMatches.Item(0).subMatches.Item(2)
            End If
            iCurrent = iCurrent + 1
        Loop
        ActiveCell.Value = RegExsult
    End If

    Set allMatches = Nothing
    Set innerMatches = Nothing
    Set RegEx = Nothing
End Sub