Glue_TXT()   ' СКЛЕИТЬ тексты из выделенных ячеек
         If TypeName(Selection) <> "Range" Then Exit Sub
         Dim rRng As Range: Set rRng = Intersect(Selection, ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible))
         If rRng Is Nothing Then Exit Sub
         If rRng.Cells.Count = 1 Then Exit Sub
         Dim Delimeter$, sLF$, sText$, rCell As Range
         If MsgBox("Переносить тексты из ячеек по строкам?", vbYesNo + vbQuestion + vbDefaultButton2, "Параметры объединения") = vbYes Then sLF = vbLf
         Delimeter = InputBox("Введите разделитель текстов ячеек:", "Параметры объединения", " ")
         For Each rCell In rRng
            If Len(rCell.Value) Then sText = sText & IIf(Len(sText), Delimeter & sLF, "") & rCell.Value
         Next rCell
         sText = Application.Trim(sText)
         With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .SetText sText: .PutInClipBoard: End With
         MsgBox "Объединённый текст помещён в буфер обмена", , "Операция завершена успешно!"
End Sub

Sub Glue_TXT_with_Chr10()   ' СКЛЕИТЬ тексты из выделенных ячеек с переносами строк
         If TypeName(Selection) <> "Range" Then Exit Sub
         Dim rRng As Range: Set rRng = Intersect(Selection, ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible))
         If rRng Is Nothing Then Exit Sub
         If rRng.Cells.Count = 1 Then Exit Sub
         Dim sText$, rCell As Range
         For Each rCell In Intersect(Selection, ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible))
            If Len(rCell.Value) Then sText = sText & IIf(Len(sText), vbLf, "") & rCell.Value
         Next rCell
         sText = Application.Trim(sText)
         With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .SetText sText: .PutInClipBoard: End With
         MsgBox "Объединённый текст помещён в буфер обмена", , "Операция завершена успешно!"
End Sub

Sub Glue_TXT_and_Num()    ' СКЛЕИТЬ тексты из выделенных ячеек в нумерованный список с переносами строк
       If TypeName(Selection) <> "Range" Then Exit Sub
       Dim rRng As Range: Set rRng = Intersect(Selection, ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible))
       If rRng Is Nothing Then Exit Sub
       If rRng.Cells.Count = 1 Then Exit Sub
       Dim sText$, rCell As Range, iItem%: iItem = 1  ' начальный номер пункта списка
       For Each rCell In rRng
          If Len(rCell.Value) Then
             sText = sText & IIf(Len(sText), vbLf, "") & CStr(iItem) & ". " & rCell.Value
             iItem = iItem + 1
          End If
       Next rCell
       sText = Application.Trim(sText)
       With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .SetText sText: .PutInClipBoard: End With
       MsgBox "Объединённый текст помещён в буфер обмена", , "Операция завершена успешно!"
End Sub