Solved

VBA: Concatenating to cells while maintaining partial formatting

Posted on 2012-04-02
9
1,073 Views
Last Modified: 2012-06-21
I have a column of cells with normal formatting. Next to it I have a column of cells which has text starting with bold and underline and then there is normal text. I need to combine the first column with the second column such that the formatting is maintained ie normal font then bold font and then normal font.
Concatenate-text-with-formatting.xlsx
0
Comment
Question by:Saqib Husain, Syed
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
9 Comments
 
LVL 16

Expert Comment

by:Peter Kwan
ID: 37800147
Please try the following code (Ref: http://www.mrexcel.com/forum/showthread.php?t=612120):

Sub ConcatenateRichText(Target As Range, Source As Range)
    Dim Cell As Range
    Dim i As Long
    Dim c As Long
    i = 1
    With Target
        .Clear
        For Each Cell In Source
            .Value = .Value & vbCrLf & Cell.Value
        Next Cell
        .Value = Mid(.Value, 3)
        .Value = Trim(.Value)
    End With
    For Each Cell In Source
        For c = 1 To Len(Cell.Value)
            With Target.Characters(i, 1).Font
                .Name = Cell.Characters(c, 1).Font.Name
                .FontStyle = Cell.Characters(c, 1).Font.FontStyle
                .Size = Cell.Characters(c, 1).Font.Size
                .Strikethrough = Cell.Characters(c, 1).Font.Strikethrough
                .Superscript = Cell.Characters(c, 1).Font.Superscript
                .Subscript = Cell.Characters(c, 1).Font.Subscript
                .OutlineFont = Cell.Characters(c, 1).Font.OutlineFont
                .Shadow = Cell.Characters(c, 1).Font.Shadow
                .Underline = Cell.Characters(c, 1).Font.Underline
                .ColorIndex = Cell.Characters(c, 1).Font.ColorIndex
            End With
            i = i + 1
        Next c
        i = i + 2
    Next Cell
End Sub

Sub ConcatCells()
    For i = 2 To Sheet1.UsedRange.Rows.Count

        ConcatenateRichText Sheet1.Range("F" & i), Sheet1.Range("A" & i & ",B" & i & "")
    Next

End Sub

Open in new window

0
 
LVL 43

Author Comment

by:Saqib Husain, Syed
ID: 37803024
This is horrendously slow. My data has something like 1000 characters in each cell and the way the program goes I might be able to do it faster manually.
0
 
LVL 43

Author Comment

by:Saqib Husain, Syed
ID: 37803036
But it does do what I want it to.
0
Salesforce Has Never Been Easier

Improve and reinforce salesforce training & adoption using WalkMe's digital adoption platform. Start saving on costly employee training by creating fast intuitive Walk-Thrus for Salesforce. Claim your Free Account Now

 
LVL 43

Author Comment

by:Saqib Husain, Syed
ID: 37803240
It also fails in some instances, probably where cells do not have partial formatting but both source cells have different formats.
0
 
LVL 42

Expert Comment

by:dlmille
ID: 37841236
Saqib - this can be done very quickly (in execution, it will take me a few to pull the code together:P), as you have IMHO a simple problem from the perspective I've been working on a solution this past day - and that's making heads/tails of HTML.

So, my brainstorm is to write the range in column B into HTML, then parse that range adding the text from column A, then open that file in Excel and copy/paste the amended values to the result column.

I'm working on it, now.

Dave
0
 
LVL 24

Assisted Solution

by:Bitsqueezer
Bitsqueezer earned 250 total points
ID: 37841366
Hi,

the code above assumes that it doesn't know the formatting of your cell so it tries to scan any character and set the formatting of any single character again.

If you have the same formatting in all of your cells, that means: it starts with a bold underline text and has a normal formatted text after this headline you can speed the things by using the following code:

Public Sub AddText()
    Dim lngULOff As Long
    Dim strAddText As String
    Dim rng As Excel.Range
    Dim i As Long
    For i = 2 To ActiveSheet.UsedRange.Rows.Count
        strAddText = Range("A" & i).Value
        Set rng = Range("B" & i)
        lngULOff = GetUnderlineEnd(rng)
        rng.Value = strAddText & vbLf & rng.Value
        With rng.Characters(Start:=1, Length:=Len(rng.Value)).Font
            .Name = "Arial"
            .FontStyle = "Regular"
            .Underline = xlUnderlineStyleNone
        End With
        With rng.Characters(Start:=Len(strAddText) + 1, Length:=lngULOff).Font
            .FontStyle = "Bold"
            .Underline = xlUnderlineStyleSingle
        End With
    Next
End Sub

Public Function GetUnderlineEnd(rngCell As Excel.Range) As Long
    Dim i As Long
    For i = 1 To rngCell.Characters.Count
        With rngCell.Characters(i, 1)
            If .Font.Underline = xlUnderlineStyleNone Then
                GetUnderlineEnd = i
                Exit For
            End If
        End With
    Next
End Function

Open in new window


It uses a function to find out the first position where the content of a cell is not underlined, then inserts the text of column A to column B, format the complete cell as normal text and then format the text beginning with the length of the text of column A +1 to the found length. The result is what you want to have. If you have different formattings in your cells you will need to add additional logic to this sub.

Cheers,

Christian
0
 
LVL 42

Accepted Solution

by:
dlmille earned 250 total points
ID: 37841934
Modifying the HTML might be simple for some, but not for me.

There is a simpler solution, though you MAY or MAY not like the outcome.  The result may be much quicker than all the formatting handling on a cell by cell basis, but the results are in WORD.  It really depends on what your end game is.  If it is to print the document, or make a PDF of it, then perhaps WORD is a solution that works.

What I couldn't seem to do was get the Word data back into Excel.  Manually copying/pasting the document ended up splitting the data onto multiple lines.  There MAY be a way to do it cell by cell, but I haven't figured that, yet.

Anyhow, it was fun to work between the two apps and pick up a bit more education on WORD.

Here's the code:
Option Explicit
Sub do_it_all()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim r As Range
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim tableNo As Integer
Dim iRow As Long
Dim iCol As Long
Dim fName As String

    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet

    fName = ThisWorkbook.path & "\myOutput.doc"
    Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = True
    Set oWordDoc = oWordApp.Documents.Add

    Set rng = wks.Range("A2", wks.Range("B" & wks.Rows.Count).End(xlUp))  'range to be converted

    rng.Copy
    
    oWordDoc.Range.PasteExcelTable linkedtoexcel:=False, wordformatting:=False, RTF:=False
    
    With oWordDoc.Tables(1)
        'introduce duplicate column for Excel Column A
        .Columns(1).Select
        oWordApp.Selection.Copy
        .Columns(1).Select
        oWordApp.Selection.Paste
        'merge each row, as requested
        For iRow = 1 To .Rows.Count
            .Cell(iRow, 2).Merge mergeto:=.Cell(iRow, 3)
        Next iRow
    End With

    'save the word document
    oWordDoc.SaveAs2 Filename:=fName, FileFormat:=wdFormatDocument

gracefulExit:

    Exit Sub 'temporarily keep the word document open.  Comment this out to close out Word on completion
    'do cleanup
    If Not oWordDoc Is Nothing Then
        oWordDoc.Close savechanges:=False
        Set oWordDoc = Nothing
    End If

    If Not oWordApp Is Nothing Then
        oWordApp.Quit
        Set oWordApp = Nothing
    End If
End Sub

Open in new window


See attached.  I'm interested whether you think this adds value to your endeavor.

Dave
Concatenate-text-with-formatting.xlsm
0
 
LVL 45

Expert Comment

by:aikimark
ID: 37842447
@Everyone

Remember to use Application.ScreenUpdating = False before your bulk updates.

Restore your application UI activity with Application.ScreenUpdating = True after you bulk updates.
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Ever notice how you can't use a new drive in Windows without having Windows assigning a Disk Signature?  Ever have a signature collision problem (especially with Virtual Machines?)  This article is intended to help you understand what's going on and…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

732 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question