Копирование+обьединение в буфер обмена, через необходимый разделитель, Значения выделеных ячеек скопировать и поместить в буфер обмена, для вставки в другие программы.
Помогите пожалуйста реализовать следующую задачу. Как я ее вижу: 1. Выделяю нужный диапазон ячеек 2. Жму на горячую клавишу, допустим Ctr+Alt+C. 3. После чего должно появиться окно, которое предлагает выбрать/ввести необходимый разделитель. (это может быть текст, пробел, цифры и тд и их сочетания) 4. После выбора/ввода необходимого разделителя, нужно чтобы значения ячеек , выделенные в пункте 1, сцепились все с этим самым разделителем и записались только в буфер обмена, для возможности последующей вставки в другие программы/документы.
Sub ttt()
Dim res As String, Sep As String
Sep = InputBox("Separator")
Sep = " " & Sep & " "
For Each Mycell In Selection
Rez = Rez & Sep & Mycell
Next
CopyText (Mid(Rez, Len(Sep) + 1))
End Sub
Sub CopyText(Text As String)
'VBA Macro using late binding to copy text to clipboard.
'By Justin Kay, 8/15/2014
Dim MSForms_DataObject As Object
Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
MSForms_DataObject.SetText Text
MSForms_DataObject.PutInClipboard
Set MSForms_DataObject = Nothing
End Sub
Но надо как то понимать кода давлять пробелы к разделителю , а когда нет. Пример сделан с учетом того что можно выделить двумерный диапазон, если одномерный то конечно join Можно Как на Ctr+Alt+C повесить - не знаю
Sub TextInClipboard()
Dim myRng As Range
Dim sDlm$, myTxt$
Set myRng = Application.InputBox("Выберите диапазон...", , , , , , , 8)
If Not myRng Is Nothing Then
sDlm = Application.InputBox("Введите/выберите разделитель...", , , , , , , 2)
Else
Exit Sub
End If
myTxt = myCONCANT(myRng, sDlm)
If Not IsError(myTxt) Then
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText myTxt
.PutInClipboard
End With
'проверка содержимого буфера обмена---------------------------------
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
MsgBox "В буфере обмена Windows содержится текст:" & vbCrLf & _
"'" & .GetText & "'"
End With
'-------------------------------------------------------------------
End If
End Sub
Private Function myCONCANT(iRng As Range, dlm$)
Dim arr(), I&, J&
arr = iRng.Value
For I = LBound(arr) To UBound(arr)
For J = LBound(arr, 2) To UBound(arr, 2)
myCONCANT = IIf(IsEmpty(myCONCANT), arr(I, J), myCONCANT & dlm & arr(I, J))
Next
Next
If IsEmpty(myCONCANT) Then myCONCANT = CVErr(xlErrNA)
End Function
Функции работы с буфером подсмотрены ЗДЕСЬ Макрос запускается по Ctrl+Shift+Q
Sub TextInClipboard_V1()
Dim res As String, Sep As String
Dim sDlm$, myTxt$
sDlm = Application.InputBox("Введите разделитель...", , , , , , , 2)
Sep = "" & sDlm & ""
For Each Mycell In Selection
Rez = Rez & Sep & Mycell
Next
CopyText (Mid(Rez, Len(Sep) + 1))
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
MsgBox "В буфере обмена содержится слеедующий текст:" & vbCrLf & _
"'" & .GetText & "'"
End With
End Sub
Sub CopyText(Text As String)
Dim MSForms_DataObject As Object
Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
MSForms_DataObject.SetText Text
MSForms_DataObject.PutInClipboard
Set MSForms_DataObject = Nothing
End Sub
Еще один вопрос, можно ли при закрытии первого диалогового окна (нажатие на крестик или отмену), чтобы просто выходил из макроса, без сцепления всех выделенных ячеек через "False", без записи этих параметров в буфер обмена и без показа итогового диалогового окна?
, и при необходимости мне пробела, я просто ставлю его в первом всплывающем окне, а если нужно пробел+разделитель+пробел, то точно также ставлю нужный мне порядок....