Sub 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