Когда я хочу объединить ячейки с текстом по вертикали, то появляется вот такое предупреждение: "В объединенной ячейке сохраняется только значение из левой верхней ячейки диапазона. Остальные значения будут потеряны." Если я нажимаю на ОК, то все данные (текст) теряются, как и говорится в предупреждении. Как то исправить и почему это происходит?
Когда я хочу объединить ячейки с текстом по вертикали, то появляется вот такое предупреждение: "В объединенной ячейке сохраняется только значение из левой верхней ячейки диапазона. Остальные значения будут потеряны." Если я нажимаю на ОК, то все данные (текст) теряются, как и говорится в предупреждении. Как то исправить и почему это происходит?MGI
Ещё можно чуть подпилить одну из процедур так, чтобы объединённый текст в конце не закидывался в буфер обмена, а выполнялось объединение ячеек и в объединённую уже вписывался текст:[vba]
Код
Private 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
Private 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
[/vba] P.S. Объединение ячеек без предупреждения выполняется в одну строку:[vba]
Ещё можно чуть подпилить одну из процедур так, чтобы объединённый текст в конце не закидывался в буфер обмена, а выполнялось объединение ячеек и в объединённую уже вписывался текст:[vba]
Код
Private 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
Private 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
[/vba] P.S. Объединение ячеек без предупреждения выполняется в одну строку:[vba]
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
