Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Объединение строк с сохранением форматирования
 
#1
13.05.2021 11:07:06
Здравствуйте!
Есть задача объединить строки с сохранением форматирования.

Нашёл решение а интернете, но пропадает знак % при объединении. Своих знаний не хватает. был бы признателен за помощь.
Код
Sub mergeStuff()

    Dim arrColors(1 To 5, 1 To 3) As Long
    Dim rIndex As Long
    Dim cIndex As Long
    Dim StartColor As Long
    Dim strOutput As String
    Dim i As Long

    For rIndex = 3 To Cells(Rows.Count, "H").End(xlUp).Row
        StartColor = 1
        strOutput = vbNullString
        For cIndex = Columns("H").Column To Columns("L").Column
            strOutput = strOutput & "," & Cells(rIndex, cIndex).Value
            arrColors(cIndex - Columns("H").Column + 1, 1) = StartColor
            arrColors(cIndex - Columns("H").Column + 1, 2) = Len(Cells(rIndex, cIndex).Value)
            arrColors(cIndex - Columns("H").Column + 1, 3) = Cells(rIndex, cIndex).Font.Color
            StartColor = StartColor + Len(Cells(rIndex, cIndex).Value) + 1
        Next cIndex

        With Cells(rIndex, "M")
            .Value = Mid(strOutput, 2) 'Remove beginning comma
            For i = 1 To UBound(arrColors, 1)
                .Characters(arrColors(i, 1), arrColors(i, 2)).Font.Color = arrColors(i, 3)
            Next i
        End With
    Next rIndex

End Sub
 
 
 
#2
13.05.2021 11:36:30
Попробуйте заменить строку:
Код
strOutput = strOutput & "," & Cells(rIndex, cIndex).Value
на такую:
Код
strOutput = strOutput & "," & Cells(rIndex, cIndex).Text
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#3
13.05.2021 11:53:39
Код
Sub SubStringColor()
    Dim rFrom As Range
    Dim rTo As Range
    
    Set rFrom = Range("G6:G8")
    Set rTo = Range("H6")
    
    Dim aStr As Variant
    Dim aCol As Variant
    ReDim aStr(1 To rFrom.Cells.Count)
    ReDim aCol(1 To rFrom.Cells.Count)
    
    Dim i As Long
    Dim c As Range
    For Each c In rFrom
        i = i + 1
        aStr(i) = c.Value
        aCol(i) = c.Font.Color
        
        Select Case i
        Case UBound(aStr): aStr(i) = aStr(i)
        Case 1: aStr(i) = aStr(i) & " "
        Case Else: aStr(i) = aStr(i) & "; "
        End Select
    Next
    
    Dim s As String
    s = Join(aStr, "")
    
    rTo.Value = s
    
    Dim x As Integer
    x = 1
    i = 1
    Do
        If i > UBound(aStr) Then Exit Do
        rTo.Characters(x, Len(aStr(i))).Font.Color = aCol(i)
        x = x + Len(aStr(i))
        i = i + 1
    Loop
    
End Sub
 
 
 
#4
13.05.2021 14:00:33
МатросНаЗебре, Дмитрий(The_Prist) Щербаков, спасибо за участие!
Оба варианта не до конца получились. В первом случае с цветом, во втором % потерялся.

Прилагаю файл.
 
 
 
#5
13.05.2021 14:34:29
Код
Sub qq()
    Dim r As Range
    Set r = [h4:j5]
    For Each cell In r.Columns(1).Cells
        With cell.Offset(, 5)
            .Value = cell.Value & " " & cell.Offset(, 1).Text & " ; " & cell.Offset(, 2).Text
            .Characters(Start:=Len(cell) + 2, Length:=Len(cell.Offset(, 1).Text)).Font.Color = cell.Offset(, 1).Font.Color
            .Characters(Start:=Len(cell) + Len(cell.Offset(, 1).Text) + 5, Length:=Len(cell.Offset(, 2).Text)).Font.Color = cell.Offset(, 2).Font.Color
        End With
    Next
End Sub
 
 
 
#6
14.05.2021 10:28:51
Спасибо большое! Всё работает) Скажите, пожалуйста, а как в Вашем примере выводить результат в определённую ячейку? Например, в H10.
 
 
 
#7
14.05.2021 10:53:49
Цитата
выводить результат в определённую ячейку
На базе кода RAN и вашего примера
Код
Sub qq_()
  With Range("H10")
    .Value = Range("H4").Value & " " & Range("I4").Text & " ; " & Range("J4").Text
    .Characters(Start:=Len(Range("H4")) + 2, Length:=Len(Range("I4").Text)).Font.Color = Range("I4").Font.Color
    .Characters(Start:=Len(Range("H4")) + Len(Range("I4").Text) + 5, Length:=Len(Range("J4").Text)).Font.Color = Range("J4").Font.Color
  End With
End Sub
 
 
 
#8
14.05.2021 11:03:57
Отлично, спасибо огромное!
 
 
 
Страницы: 1
Наверх