Макрос для объединения двух соседних ячеек с сохранением формата первой ячейки

Question

Я использую приведенный ниже код для объединения двух соседних ячеек с разрывом строки, но я хотел бы сохранить исходное форматирование первой ячейки с подчеркиванием. Как я могу встроить строку кода в код ниже, чтобы сохранить форматирование первой ячейки. Пожалуйста, посмотрите на изображение ниже, мне нужно что-то вроде этого.

Но текущий макрос только объединяет, но не сохраняет формат подчеркивания.

Мне также нужно объединить результаты в отдельные ячейки с форматированием источника.

    Sub linebreak()

Dim myRange As Range

Set myRange = Range("K2:K51")  'Set the range of the first column cells

For Each c In myRange.Cells
    If c.Value <> "" Then
        'Concatenate in 3rd column
        If c.Offset(0, 1).Value = "" Then
            c.Offset(0, 2).Value = c.Value
        Else
            c.Offset(0, 2).Value = c.Value & Chr(10) & c.Offset(0, 1).Value
            'Apply formatting with preserving colors
            c.Offset(0, 2).Characters(Len(CStr(c.Value)) + 2, Len(CStr(c.Offset(0, 1).Value))).Font.Color = c.Offset(0, 1).Font.Color
            c.Offset(0, 2).Characters(Len(CStr(c.Value)) + 2, Len(CStr(c.Offset(0, 1).Value))).Font.Italic = c.Offset(0, 1).Font.Italic
            c.Offset(0, 2).Characters(Len(CStr(c.Value)) + 2, Len(CStr(c.Offset(0, 1).Value))).Font.Bold = c.Offset(0, 1).Font.Bold
        End If
    End If
Next c


End Sub

Answer 1

Попробуйте, пожалуйста:

Sub linebreak()
Dim myRange As Range, c As Range
Set myRange = Range("K2:K6")  'Set the range of the first column cells

For Each c In myRange.Cells
    If c.Value <> "" Then
        'Concatenate in 3rd column
        If c.Offset(0, 1).Value = "" Then
            c.Offset(0, 2).Value = c.Value
        Else
            c.Offset(0, 2).Value = c.Value & Chr(10) & c.Offset(0, 1).Value
            'Apply formatting with preserving colors
            c.Offset(0, 2).Characters(1, Len(CStr(c.Value))).Font.Color = c.Font.Color
            c.Offset(0, 2).Characters(1, Len(CStr(c.Value))).Font.Italic = c.Font.Italic
            c.Offset(0, 2).Characters(1, Len(CStr(c.Value))).Font.Bold = c.Font.Bold
            c.Offset(0, 2).Characters(1, Len(CStr(c.Value))).Font.Underline = c.Font.Underline
        End If
    End If
 Next c
End Sub

Вы должны начать символы для форматирования с 1, использовать Len(c.Value) для форматирования длины, применить формат c и использовать Underline для делать то, что вы хотели ...

Здесь решение для вашего последнего запроса:

Sub AllConc()
 Dim myRange As Range, c As Range, strC As String
 Set myRange = Range("K2:K5")
 For Each c In myRange
    If c.Value <> Empty Then
        strC = strC & c.Value & vbCrLf
    End If
 Next
 strC = left(strC, Len(strC) - 1)
 Range("K6").Value = strC
End Sub

Объединенная строка возвращается в "K6".

Answer 2

Вы ссылаетесь на неправильный столбец с Offset. Ваша основная ссылка:

Set myRange = Range("K2:K51")  'Set the range of the first column cells

Согласно вашему собственному коду, это первый столбец ячеек.

А потом вы делаете c.Offset(0, 1).Font.Color, поэтому вы ссылаетесь на столбец L, где не применяется формат. ЭТО должно быть c.Font.Color

Попробуйте:

Sub linebreak()

Dim myRange As Range
Dim c As Range

Set myRange = Range("K2:K51")  'Set the range of the first column cells

For Each c In myRange.Cells
    If c.Value <> "" Then
    'Concatenate in 3rd column
        If c.Offset(0, 1).Value = "" Then
            c.Offset(0, 2).Value = c.Value
        Else
            c.Offset(0, 2).Value = c.Value & Chr(10) & c.Offset(0, 1).Value
            'Apply formatting with preserving colors
            c.Offset(0, 2).Characters(Len(CStr(c.Value)) + 2, Len(CStr(c.Offset(0, 1).Value))).Font.Color = c.Font.Color
            c.Offset(0, 2).Characters(Len(CStr(c.Value)) + 2, Len(CStr(c.Offset(0, 1).Value))).Font.Italic = c.Font.Italic
            c.Offset(0, 2).Characters(Len(CStr(c.Value)) + 2, Len(CStr(c.Offset(0, 1).Value))).Font.Bold = c.Font.Bold
        End If
    End If
Next c


End Sub