Option Explicit
Sub MergeToOneCell()
    Const sDELIM As String = " "
    Dim rCell As Range
    Dim sMergeStr As String
    If TypeName(Selection) <> "Range" Then Exit Sub
    With Selection
        For Each rCell In .Cells
            sMergeStr = sMergeStr & sDELIM & rCell.Text
        Next rCell
        Application.DisplayAlerts = False
        .Merge Across:=False
        Application.DisplayAlerts = True
        .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM))
    End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Const txt = "[URL=https://www.pochta.ru/tracking/#"]https://www.pochta.ru/tracking/#&quot[/URL];
    Dim url$, IE As Object
    url = txt & Target.Value
    If Not Intersect(Target, [a:a]) Is Nothing Then
     On Error Resume Next
     If Not IsEmpty(Target) Then ActiveWorkbook.FollowHyperlink url
    End If
End Sub


Function Get_ststus(kod)
     Dim oXMLHTTP
     Dim url, GetHTTPResponse
     
     On Error Resume Next
     url = "[URL=https://www.pochta.ru/tracking/#"]https://www.pochta.ru/tracking/#&quot[/URL]; & kod
     Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
     With oXMLHTTP
        .Open "GET", url, False
        .SetRequestHeader "Cache-Control", "max-age=0"
        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/48.0.2564.41 Safari/537.36 OPR/35.0.2066.10 (Edition beta)"
        .SetRequestHeader "Accept-Encoding", "deflate"
        .SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
        .send
         Get_ststus = Split(Split(Replace(.responseText, Chr(34), ""), "status:")(1), ",")(0)
     End With
     Set oXMLHTTP = Nothing
End Function

    clColumnNames.Add "Город отгрузки"
    clColumnNames.Add "Код и наименование места отгрузки" ' вот этот столбец надо разделить на два КОД МЕСТО (честно говоря ума не хватает сделать)
    clColumnNames.Add "АД адр"

Sub concat()    Const sDELIM As String = ""
    Dim rCell As Range
    Dim sMergeStr As String
    If TypeName(Selection) <> "Range" Then Exit Sub
    With Selection
        For Each rCell In .Cells
            sMergeStr = sMergeStr & sDELIM & rCell.Text
        Next rCell
        Application.DisplayAlerts = False
        .Merge Across:=False
        Application.DisplayAlerts = True
        .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM))
    End With
End Sub

SubAdres
TextToDisplay

Sub Test()
Dim iCell As Range, Priznak As Variant
    Priznak = Application.InputBox("признак переноса сроки", "Екатеринбург", "Екатеринбург")
        For Each iCell In Range("A2", [A2].End(xlDown))
             If iCell = Priznak Then
                With Sheets("ЕКБ")
                    iCell.EntireRow.Copy Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
            End With
        End If
    Next iCell
    MsgBox "строки содержащие" & Priznak & "в столбце а скопированы на другой лист", vbInformation, ""
End Sub