текст из нескольких ячеек в одну

[Tirendus]

сабж, облазил пол справки, так и не нашел как скопировать текст из ячейки и вставить его в другую без замещения, а через запятую. Помогите плз

[EducatedFool]

скопировать текст из ячейки и вставить его в другую без замещения

Ничего не понял...
Давай подробнее.
К примеру, выделяем ячейки с a5 по a7, нажимаем Копировать, выделяем ячейку e2, и нажимаем некую комбинацию клавиш, в результате чего в ячейке e2 появляется содержимое ячеек a5, a6 и a7 через запятую.
Пробелы после запятых ставить?

[Tirendus]

Ничего не понял...

Да нет, всё правильно Еще было бы здорово, если бы при таком действии, что ты описал сохранялся цвет текста... да, пробелы после запятых нужны

[EducatedFool]

Вот весь код:

Public ra As Range

Sub Копирование()
    Set ra = Selection
    Application.StatusBar = "Скопирован диапазон " & ra.Address
End Sub

Sub Вставка()
    Dim cell As Range, acell As Range: delim = ", ": Set acell = ActiveCell
    If ra Is Nothing Then Exit Sub
    Dim fc As Range, pos As Long: Set fc = ra.Cells(1)
    For Each cell In ra.Cells: txt = txt & delim & cell.Value: Next
    txt = Mid(txt, Len(delim) + 1): acell.Value = txt

    For Each cell In ra.Cells
        l = Len(cell.Value): s = pos + 1: e = s + l
        acell.Characters(s, l).Font.Color = cell.Font.Color
        acell.Characters(s, l).Font.Bold = cell.Font.Bold
        pos = pos + l + Len(delim)
        acell.Characters(e, Len(delim)).Font.Color = vbBlack    ' запятые чёрным цветом
    Next
    Application.StatusBar = False
End Sub


Private Sub Workbook_Open()
    Application.OnKey "^+c", "Копирование"
    Application.OnKey "^+v", "Вставка"
End Sub

Пример и описание во вложении:

[Tirendus]

спасибо, сейчас посмотрю

супер вообще)) приду домой, буду учить твой код, мб что-то пойму

[Алекс14]

Сообщение от EducatedFool

Вот весь код:

Public ra As Range

Sub Копирование()
    Set ra = Selection
    Application.StatusBar = "Скопирован диапазон " & ra.Address
End Sub

Sub Вставка()
    Dim cell As Range, acell As Range: delim = ", ": Set acell = ActiveCell
    If ra Is Nothing Then Exit Sub
    Dim fc As Range, pos As Long: Set fc = ra.Cells(1)
    For Each cell In ra.Cells: txt = txt & delim & cell.Value: Next
    txt = Mid(txt, Len(delim) + 1): acell.Value = txt

    For Each cell In ra.Cells
        l = Len(cell.Value): s = pos + 1: e = s + l
        acell.Characters(s, l).Font.Color = cell.Font.Color
        acell.Characters(s, l).Font.Bold = cell.Font.Bold
        pos = pos + l + Len(delim)
        acell.Characters(e, Len(delim)).Font.Color = vbBlack    ' запятые чёрным цветом
    Next
    Application.StatusBar = False
End Sub


Private Sub Workbook_Open()
    Application.OnKey "^+c", "Копирование"
    Application.OnKey "^+v", "Вставка"
End Sub

Пример и описание во вложении:

Супер воще.
А вот этот диапозон

delim = ", "

как сделать, чтобы был перенос текста на новую строку внутри заданного параметра?

[EducatedFool]

как сделать, чтобы был перенос текста на новую строку внутри заданного параметра?

delim = vbLf

[Алекс14]

Благодарю, это то что я искал.
Спасибо.
Всех с наступающим Новым Годом.

[Viktorkv]

Здравствуйте! Помогите изменить макрос. Нужно, что бы в выбранном диапазоне копировались только уникальные значения.

[IgorGO]

Sub CopyUnique()
  Dim rg As Range, c As Range, u As Range, d
  Set rg = Selection
  Set d = CreateObject("scripting.dictionary")
  For Each c In rg
    If Not IsEmpty(c) Then
      If Not d.exists(c.Value) Then d.Add c.Value, 1:  If u Is Nothing Then Set u = c Else Set u = Union(u, c)
    End If
  Next
  u.Copy
End Sub

выбранный диапазон должен содержать 1 колонку или 1 строку данных