Solved

VBA: Concatenating to cells while maintaining partial formatting

Posted on 2012-04-02
9
955 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
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
 
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
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 41

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 41

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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
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 demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

747 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now