VBA Font detail loss

[Walter Briscoe]

The following is a slightly simplified extract from some of my code:
POfInterest = ""
For J = 3 To 12
POfInterest = POfInterest & .Cells(J, 2)
Next
End With
ActiveCell = ActiveCell & POfInterest

Font and boldness in .Cells(J, 2) do not get copied to ActiveCell.
How can I ensure such characteristics are copied?
Each field is a mixture of bold and plain text.

 

[Joel]

The format is not copies when using the equal sign. You need to use copy

from
POfInterest = POfInterest & .Cells(J, 2)
to
POfInterest & .Cells(J, 2).copy _
destination:=POfInterest

 

[Bernie Deitrick]

Walter,

You need to apply the font detail (Bold) on a character by character basis
to the resulting string.

In the code below, I have change POfInterest to a cell on the "With Sheet"

If you have other font details that you want to apply

HTH,
Bernie
MS Excel MVP

Sub Macro1()
Dim POfInterest As Range
Dim myC As Range
Dim k As Integer
Dim j As Integer
Dim i As Integer

With ActiveSheet

Set POfInterest = .Cells(1, 1)
For j = 3 To 12
POfInterest.Value = POfInterest.Value & .Cells(j, 2).Value
Next j
POfInterest.Value = ActiveCell.Value & POfInterest.Value

For i = 1 To Len(ActiveCell.Value)
POfInterest.Characters(Start:=i, Length:=1).Font.Bold = _
ActiveCell.Characters(Start:=i, Length:=1).Font.Bold
Next i

k = Len(ActiveCell.Value)

For j = 3 To 12
For i = 1 To Len(.Cells(j, 2).Value)
k = k + 1
POfInterest.Characters(Start:=k, Length:=1).Font.Bold = _
.Cells(j, 2).Characters(Start:=i, Length:=1).Font.Bold
Next i
Next j

POfInterest.Copy ActiveCell
POfInterest.Clear
End With

End Sub

 

[Bernie Deitrick]

If you have other font details that you want to apply

Ooops.... Hit send too soon!

......you need to do that on a detail by detail basis.

HTH,
Bernie
MS Excel MVP

 

[Rick Rothstein]

You must set the characters' properties (Bold, Color, Italics, etc.) one
character at a time. Here is a macro that demonstrates the technique...

Sub Test()
Dim J As Long, Start As Long
Dim C As Range, Source As Range, Temp As Range
'.....
'.....
Set Source = Range("B2:B12")
Set Temp = Cells(Cells(Rows.Count, Source.Column).End(xlUp).Row + 1,
Source.Column)
Temp.Value = ActiveCell.Value &
Join(WorksheetFunction.Transpose(Source.Value), "")
For Each C In Union(ActiveCell, Source)
For J = 1 To Len(C.Value)
Start = Start + 1
With Temp.Characters(Start, 1).Font
.Bold = C.Characters(J, 1).Font.Bold
.Color = C.Characters(J, 1).Font.Color
.Italic = C.Characters(J, 1).Font.Italic
End With
Next
Next
Temp.Copy ActiveCell
Temp.Clear
End Sub

Note that I assume your source range of text will *always* be a contiguous
column of values. Making that assumption allows me to concatenate all the
cells in the range using a single statement (see the assignment statement to
the Temp variable).

In my example above, I set the Bold, Color and Italic properties of the
characters. If there are other properties that you might have set in your
characters, then you will have to add them to the lie inside the
With/EndWith block (just follow the structure of the other statements in
it). Also, my code will preserve any font settings you have in the
ActiveCell that you concatenated the source cells with as well.

 

[Rick Rothstein]

Sorry, I meant to post the macro so its long lines would not word wrap in
your newsreader. Here is that reformatted code...

Sub Test()
Dim J As Long, Start As Long
Dim C As Range, Source As Range, Temp As Range
'.....
'.....
Set Source = Range("B2:B12")
Set Temp = Cells(Cells(Rows.Count, Source.Column). _
End(xlUp).Row + 1, Source.Column)
Temp.Value = ActiveCell.Value & Join(WorksheetFunction. _
Transpose(Source.Value), "")
For Each C In Union(ActiveCell, Source)
For J = 1 To Len(C.Value)
Start = Start + 1
With Temp.Characters(Start, 1).Font
.Bold = C.Characters(J, 1).Font.Bold
.Color = C.Characters(J, 1).Font.Color
.Italic = C.Characters(J, 1).Font.Italic
End With
Next
Next
Temp.Copy ActiveCell
Temp.Clear
End Sub

 

[Walter Briscoe]

In message <#[email protected]> of Sun, 20 Sep 2009
10:47:42 in microsoft.public.excel.programming, Bernie Deitrick

Ooops.... Hit send too soon!

.....you need to do that on a detail by detail basis.

Thanks to Joel <[email protected]>, Bernie Deitrick
<[email protected]>, Rick Rothstein <[email protected]
erizon.net> for help. It took me a while to absorb the information.

(I had forgotten to mention I use Excel 2003.)

Joel's suggestion of POfInterest & .Cells(J, 2).copy _
destination:=POfInterest gave a syntax error. I am afraid I
could not figure what was intended.
Rick's suggestion of union frightened me as I had not used union before
and found a seemingly undocumented restriction that all arguments to
union must be on the same sheet.
So I took your work, Bernie, in creating this code which - ugly as it is
- does what I need. Somebody may propose some simplification

Private Sub ExpandQuestion()
Dim I As Long
Dim J As Long
Dim K As Long
Dim L As Long
Dim SheetName As String
Dim Scratch As Range

For I = 1 To 4
SheetName = "3." & I
If InStr(ActiveCell, SheetName) Then
With Workbooks("foo.xls").Sheets(SheetName)
Set Scratch = .Cells(1, 14)
Scratch.Value = ActiveCell.Value
For J = 3 To 12
If .Cells(J, 1) = 0 Then Scratch.Value = _
Scratch.Value & .Cells(J, 2).Value _
& .Cells(J, 14).Value
Next
K = Len(ActiveCell.Value)
For J = 3 To 12
If .Cells(J, 1) = 0 Then
For L = 1 To Len(.Cells(J, 2))
K = K + 1
Scratch.Characters(Start:=K, _
Length:=1).Font.Bold = _
.Cells(J, 2).Characters(Start:=L, _
Length:=1).Font.Bold
Next
For L = 1 To Len(.Cells(J, 14))
K = K + 1
Scratch.Characters(Start:=K, _
Length:=1).Font.Bold = _
.Cells(J, 14).Characters(Start:=L, _
Length:=1).Font.Bold
Next
End If
Next
Scratch.WrapText = ActiveCell.WrapText
Scratch.Copy ActiveCell
End With
Exit For
End If
Next
End Sub

Thanks, again, for all the help.