locked
Concatenate while maintaining original formatting RRS feed

  • Question

  • I want to concatenate the contents of cells while maintaining the original formatting. I have a table with 5 columns and 200 rows, and for each row of the table, I want to concatenate the first 4 columns and put the result into column 5. eg. in row 5, I want to concatenate A5, B5, C5 and D5 and put the contents into E5.I want to do this for each of the 200 rows. I have some code that works for an individual row, but I don't know how to get the coding to do it for all the other rows. I also want to be able to run this from a command button and concatenate all the rows in the table with a single click. Is this possible? Any help much appreciated. The code I have is below:

    Option Explicit
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rSrc As Range
    Dim rDest As Range
    Dim c As Range
    Dim sTemp As String
    Dim sFmt()
    Dim i As Long, j As Long
    Application.ScreenUpdating = False

    Set rSrc = Range("A1:J1")
    Set rDest = Range("K1")

    Const lNumOfFontProps As Long = 3

    ReDim sFmt(0 To rSrc.Count - 1, 0 To lNumOfFontProps)

    i = 0
    For Each c In rSrc
    sTemp = sTemp & c.Text 'may need to use Value if LEN>255
    sFmt(i, 0) = Len(c.Text) 'length of string
    sFmt(i, 1) = c.Font.Bold
    sFmt(i, 2) = c.Font.Italic
    sFmt(i, 3) = c.Font.Size
    'add more depending on font properties required
    i = i + 1
    Next c

    j = 1
    With rDest
    .Value = sTemp
    For i = 0 To UBound(sFmt, 1)
    With .Characters(j, sFmt(i, 0))
    .Font.Bold = sFmt(i, 1)
    .Font.Italic = sFmt(i, 2)
    .Font.Size = sFmt(i, 3)
    End With
    j = j + sFmt(i, 0)
    Next i
    End With

    Application.ScreenUpdating = True
    End Sub

     

    Tuesday, March 6, 2012 1:41 AM

Answers

  • Try something like this

    Type tFormats
         Bold As Boolean
         Italic As Boolean
         Color As Long
         Underline As Long
         ' add more formats here
         Len As Long
    End Type
    
    Sub test()
    Dim numRows As Long
    Dim r As Long, c As Long, k As Long, Start As Long
    Dim s As String
    Dim rng As Range, rRow As Range, rCel As Range
    Dim fmts(1 To 4) As tFormats
    
    Set rng = Range("A2:D2")        ' first row
         numRows = 5
         Set rng = rng.Resize(numRows, 4)
            For r = 1 To rng.Rows.Count
                 s = ""
                 For c = 1 To 4
                         With rng(r, c)
                                 s = s & .Text
                                 fmts(c).Len = Len(.Text)
                                 With .Font
                                         fmts(c).Bold = .Bold
                                         fmts(c).Italic = .Italic
                                         fmts(c).Underline = .Underline
                                         If .ColorIndex < 0 Then
                                                 fmts(c).Color = .ColorIndex
                                         Else
                                                 fmts(c).Color = .Color
                                         End If
                                 End With
                         End With
                 Next
                    rng(r, 5) = s
                 Start = 1
                    For k = 1 To 4
                         With rng(r, 5).Characters(Start, fmts(k).Len).Font
                                 .Bold = fmts(k).Bold
                                 .Italic = fmts(k).Italic
                                 .Underline = fmts(k).Underline
                                 .Color = fmts(k).Color
                                 If fmts(k).Color < 0 Then
                                         .ColorIndex = fmts(k).Color
                                 Else
                                         .Color = fmts(k).Color
                                 End If
                         End With
                         Start = Start + fmts(k).Len
                 Next
         Next
    
    End Sub

    Change the "first row" and numRows to suit, and assign to a button. Also
    Peter Thornton

    • Proposed as answer by danishani Friday, March 16, 2012 2:42 AM
    • Marked as answer by chuxtable Friday, March 16, 2012 2:51 AM
    Tuesday, March 6, 2012 12:48 PM
  • You code wouldn't work as a button because the name of the macro was wrong.  You also can't call a macro from a button if the macro has a parameter list. I used the selected cells to define the region the macro was concatinatioing and put the destination one cell to the right of the selected area.

    Option Explicit
    Sub Copyformating()
    Const lNumOfFontProps As Long = 3
    Dim rSrc As Range
    Dim rDest As Range
    Dim c As Range
    Dim RowOffsetCount As Long
    Dim ColOffsetCount As Long
    Dim sTemp As String
    Application.ScreenUpdating = False
    Set rSrc = ActiveWindow.RangeSelection
    ReDim sFmt(0 To rSrc.Count - 1, 0 To lNumOfFontProps)
    'set format of destination column to text
    Columns(rSrc.Columns.Count + 1).NumberFormat = "@"
    For RowOffsetCount = 0 To (rSrc.Rows.Count - 1)
       sTemp = ""
       For ColOffsetCount = 0 To (rSrc.Columns.Count - 1)
          Set c = rSrc(RowOffsetCount + 1, ColOffsetCount + 1)
          sTemp = sTemp & c.Text 'may need to use Value if LEN>255
          sFmt(ColOffsetCount, 0) = Len(c.Text) 'length of string
          sFmt(ColOffsetCount, 1) = c.Font.Bold
          sFmt(ColOffsetCount, 2) = c.Font.Italic
          sFmt(ColOffsetCount, 3) = c.Font.Size
          'add more depending on font properties required
       Next ColOffsetCount
       
       Set rDest = rSrc(1, 1).Offset(rowoffset:=RowOffsetCount, _
          columnoffset:=rSrc.Columns.Count)
       
       With rDest
          .Value = sTemp
          For ColOffsetCount = 0 To (rSrc.Columns.Count - 1)
             With .Characters(sFmt(ColOffsetCount, 0))
                .Font.Bold = sFmt(ColOffsetCount, 1)
                .Font.Italic = sFmt(ColOffsetCount, 2)
                .Font.Size = sFmt(ColOffsetCount, 3)
             End With
             
          Next ColOffsetCount
       End With
    Next RowOffsetCount
    Application.ScreenUpdating = True
    End Sub


    jdweng

    • Marked as answer by chuxtable Thursday, March 15, 2012 11:40 PM
    Tuesday, March 6, 2012 1:51 PM

All replies

  • Try something like this

    Type tFormats
         Bold As Boolean
         Italic As Boolean
         Color As Long
         Underline As Long
         ' add more formats here
         Len As Long
    End Type
    
    Sub test()
    Dim numRows As Long
    Dim r As Long, c As Long, k As Long, Start As Long
    Dim s As String
    Dim rng As Range, rRow As Range, rCel As Range
    Dim fmts(1 To 4) As tFormats
    
    Set rng = Range("A2:D2")        ' first row
         numRows = 5
         Set rng = rng.Resize(numRows, 4)
            For r = 1 To rng.Rows.Count
                 s = ""
                 For c = 1 To 4
                         With rng(r, c)
                                 s = s & .Text
                                 fmts(c).Len = Len(.Text)
                                 With .Font
                                         fmts(c).Bold = .Bold
                                         fmts(c).Italic = .Italic
                                         fmts(c).Underline = .Underline
                                         If .ColorIndex < 0 Then
                                                 fmts(c).Color = .ColorIndex
                                         Else
                                                 fmts(c).Color = .Color
                                         End If
                                 End With
                         End With
                 Next
                    rng(r, 5) = s
                 Start = 1
                    For k = 1 To 4
                         With rng(r, 5).Characters(Start, fmts(k).Len).Font
                                 .Bold = fmts(k).Bold
                                 .Italic = fmts(k).Italic
                                 .Underline = fmts(k).Underline
                                 .Color = fmts(k).Color
                                 If fmts(k).Color < 0 Then
                                         .ColorIndex = fmts(k).Color
                                 Else
                                         .Color = fmts(k).Color
                                 End If
                         End With
                         Start = Start + fmts(k).Len
                 Next
         Next
    
    End Sub

    Change the "first row" and numRows to suit, and assign to a button. Also
    Peter Thornton

    • Proposed as answer by danishani Friday, March 16, 2012 2:42 AM
    • Marked as answer by chuxtable Friday, March 16, 2012 2:51 AM
    Tuesday, March 6, 2012 12:48 PM
  • You code wouldn't work as a button because the name of the macro was wrong.  You also can't call a macro from a button if the macro has a parameter list. I used the selected cells to define the region the macro was concatinatioing and put the destination one cell to the right of the selected area.

    Option Explicit
    Sub Copyformating()
    Const lNumOfFontProps As Long = 3
    Dim rSrc As Range
    Dim rDest As Range
    Dim c As Range
    Dim RowOffsetCount As Long
    Dim ColOffsetCount As Long
    Dim sTemp As String
    Application.ScreenUpdating = False
    Set rSrc = ActiveWindow.RangeSelection
    ReDim sFmt(0 To rSrc.Count - 1, 0 To lNumOfFontProps)
    'set format of destination column to text
    Columns(rSrc.Columns.Count + 1).NumberFormat = "@"
    For RowOffsetCount = 0 To (rSrc.Rows.Count - 1)
       sTemp = ""
       For ColOffsetCount = 0 To (rSrc.Columns.Count - 1)
          Set c = rSrc(RowOffsetCount + 1, ColOffsetCount + 1)
          sTemp = sTemp & c.Text 'may need to use Value if LEN>255
          sFmt(ColOffsetCount, 0) = Len(c.Text) 'length of string
          sFmt(ColOffsetCount, 1) = c.Font.Bold
          sFmt(ColOffsetCount, 2) = c.Font.Italic
          sFmt(ColOffsetCount, 3) = c.Font.Size
          'add more depending on font properties required
       Next ColOffsetCount
       
       Set rDest = rSrc(1, 1).Offset(rowoffset:=RowOffsetCount, _
          columnoffset:=rSrc.Columns.Count)
       
       With rDest
          .Value = sTemp
          For ColOffsetCount = 0 To (rSrc.Columns.Count - 1)
             With .Characters(sFmt(ColOffsetCount, 0))
                .Font.Bold = sFmt(ColOffsetCount, 1)
                .Font.Italic = sFmt(ColOffsetCount, 2)
                .Font.Size = sFmt(ColOffsetCount, 3)
             End With
             
          Next ColOffsetCount
       End With
    Next RowOffsetCount
    Application.ScreenUpdating = True
    End Sub


    jdweng

    • Marked as answer by chuxtable Thursday, March 15, 2012 11:40 PM
    Tuesday, March 6, 2012 1:51 PM
  • A belated thankyou to both Joel and Peter for your suggestions. I eventually used Peter's solution - it worked a treat thankyou. I will also use Joel's in the future I am sure
    Thursday, March 15, 2012 11:40 PM