Есть у меня в заначке UDF, делающая, похоже, то, что Вам надо. Подпилите под макрос сами.
[vba]
Код
Function СКЛЕИТЬ(Диапазон As Range, _ Optional Разделитель$ = "", _ Optional Переносить As Boolean = True) As String '--------------------------------------------------------------------------------------- ' Procedure : СКЛЕИТЬ ' Purpose : склеить тексты из выделенных ячеек в одну строку с опционально задаваемыми разделителями данных ' Notes : по умолчанию включен перенос строк внутри ячейки '--------------------------------------------------------------------------------------- Разделитель = Разделитель & IIf(Переносить, vbLf, "") If Диапазон.Cells.Count = 1 Then СКЛЕИТЬ = Application.Trim(Диапазон.Value): Exit Function Dim Arr, i& Arr = Application.Trim(Диапазон.Value) If Диапазон.Rows.Count = 1 Then СКЛЕИТЬ = Join(Arr, Разделитель): Exit Function For i = 1 To UBound(Arr) СКЛЕИТЬ = СКЛЕИТЬ & IIf(Len(СКЛЕИТЬ), Разделитель, "") & Join(Application.Index(Arr, i, 0), Разделитель) Next End Function
[/vba]
Есть у меня в заначке UDF, делающая, похоже, то, что Вам надо. Подпилите под макрос сами.
[vba]
Код
Function СКЛЕИТЬ(Диапазон As Range, _ Optional Разделитель$ = "", _ Optional Переносить As Boolean = True) As String '--------------------------------------------------------------------------------------- ' Procedure : СКЛЕИТЬ ' Purpose : склеить тексты из выделенных ячеек в одну строку с опционально задаваемыми разделителями данных ' Notes : по умолчанию включен перенос строк внутри ячейки '--------------------------------------------------------------------------------------- Разделитель = Разделитель & IIf(Переносить, vbLf, "") If Диапазон.Cells.Count = 1 Then СКЛЕИТЬ = Application.Trim(Диапазон.Value): Exit Function Dim Arr, i& Arr = Application.Trim(Диапазон.Value) If Диапазон.Rows.Count = 1 Then СКЛЕИТЬ = Join(Arr, Разделитель): Exit Function For i = 1 To UBound(Arr) СКЛЕИТЬ = СКЛЕИТЬ & IIf(Len(СКЛЕИТЬ), Разделитель, "") & Join(Application.Index(Arr, i, 0), Разделитель) Next End Function
Russel, Спасибо, конечно можно и формулой это как решение у меня было - но оно не удобно, макрос на кнопку посадил и в любом новом листе доступно - а формулу придется каждый раз копировать
Russel, Спасибо, конечно можно и формулой это как решение у меня было - но оно не удобно, макрос на кнопку посадил и в любом новом листе доступно - а формулу придется каждый раз копироватьЛехаа
Sub объеденить_ячейки_по_строкам() If TypeName(Selection) <> "Range" Then Exit Sub Const sDELIM$ = "|" Dim rRow As Range, i&, sMergeStr$ For i = 1 To Selection.Rows.Count Set rRow = Intersect(Selection.Cells, Selection(i, 1).EntireRow) sMergeStr = Join(Application.Index(rRow.Value, 1, 0), sDELIM) rRow.ClearContents: rRow(1).Value = sMergeStr Next i End Sub
[/vba] А уж разделитель Вы сами какой нравится поставьте (да хоть vbLF если хотите переносы). А для отладки | удобнее.
Sub объеденить_ячейки_по_строкам() If TypeName(Selection) <> "Range" Then Exit Sub Const sDELIM$ = "|" Dim rRow As Range, i&, sMergeStr$ For i = 1 To Selection.Rows.Count Set rRow = Intersect(Selection.Cells, Selection(i, 1).EntireRow) sMergeStr = Join(Application.Index(rRow.Value, 1, 0), sDELIM) rRow.ClearContents: rRow(1).Value = sMergeStr Next i End Sub
[/vba] А уж разделитель Вы сами какой нравится поставьте (да хоть vbLF если хотите переносы). А для отладки | удобнее.Alex_ST
Сообщение отредактировал Alex_ST - Пятница, 06.06.2014, 14:47
Sub объеденить_ячейки_по_строкам() If TypeName(Selection) <> "Range" Then Exit Sub Const sDELIM$ = "|" Dim rRow As Range, i&, sMergeStr$ For i = 1 To Selection.Rows.Count Set rRow = Intersect(Selection.Cells, Selection(i, 1).EntireRow) sMergeStr = Join(Application.Index(rRow.Value, 1, 0), sDELIM) rRow.ClearContents: rRow(1).Value = sMergeStr Next i End Sub
не работает останавливается на: sMergeStr = Join(Application.Index(rRow.Value, 1, 0), sDELIM)
Sub объеденить_ячейки_по_строкам() If TypeName(Selection) <> "Range" Then Exit Sub Const sDELIM$ = "|" Dim rRow As Range, i&, sMergeStr$ For i = 1 To Selection.Rows.Count Set rRow = Intersect(Selection.Cells, Selection(i, 1).EntireRow) sMergeStr = Join(Application.Index(rRow.Value, 1, 0), sDELIM) rRow.ClearContents: rRow(1).Value = sMergeStr Next i End Sub
не работает останавливается на: sMergeStr = Join(Application.Index(rRow.Value, 1, 0), sDELIM)Лехаа
Сообщение отредактировал Лехаа - Пятница, 06.06.2014, 14:56
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
это как решение у меня было - но оно не удобно, макрос на кнопку посадил и в любом новом листе доступно - а формулу придется каждый раз копировать
, выложил файл как ты просил в 2003 версии