Loop help

[DavidGMullins]

Hi All,

Can you help me turn this into a loop/iteration macro? The macro
takes the value in AA2 and AB2 and concatenates them (with a charater
return) while preserving rich text formatting from the source cells
and places the result into AC2. I need this macro to then do this
down the rest of my results (preferably just as far down as their are
results in Column G). Any help would be greatly appreciated.

Sub PreserveRichText()

Dim SourceCells As Range
Dim DestRange As Range
Dim Cell As Range
Dim SourceChar As Long
Dim DestChar As Long
Dim SourceFont As Font
Const DELIM As String = vbCr

Set SourceCells = Range("AA2:AB2")
Set DestRange = Range("AC2")

DestRange.ClearContents

'Build the string first
For Each Cell In SourceCells
DestRange.Value = DestRange.Value & DELIM & Cell.Value
Next

DestRange.Value = Mid(DestRange.Value, Len(DELIM) + 1)

'Now process each Char
For Each Cell In SourceCells
For SourceChar = 1 To Cell.Characters.Count
Set SourceFont = Cell.Characters(SourceChar, 1).Font
DestChar = DestChar + 1


With DestRange.Characters(DestChar, 1).Font
.Bold = SourceFont.Bold
.ColorIndex = SourceFont.ColorIndex
.FontStyle = SourceFont.FontStyle
.Name = SourceFont.Name
.Size = SourceFont.Size
.Underline = SourceFont.Underline
' Other properties ?
End With
Next
DestChar = DestChar + Len(DELIM)

Next
End Sub

Thanks very much,
-David

 

[Guest]

Sub PreserveRichText()

Dim SourceCells As Range
Dim DestRange As Range
Dim Cell As Range
Dim SourceChar As Long
Dim DestChar As Long
Dim SourceFont As Font
Const DELIM As String = vbCr


'Set SourceCells = Range("AA2:AB2")
'Set DestRange = Range("AC2")

set r1 = Range(Range("G2"),Range("G2").End(xldown))
for each cell1 in r1
Set SourceCells =Cells(cell1.row,"AA").Resize(1,2)
Set DestRange = SourceCells.(1,3)(1)

DestRange.ClearContents


'Build the string first
For Each Cell In SourceCells
DestRange.Value = DestRange.Value & DELIM & Cell.Value
Next

DestRange.Value = Mid(DestRange.Value, Len(DELIM) + 1)

'Now process each Char
For Each Cell In SourceCells
For SourceChar = 1 To Cell.Characters.Count
Set SourceFont = Cell.Characters(SourceChar, 1).Font
DestChar = DestChar + 1


With DestRange.Characters(DestChar, 1).Font
.Bold = SourceFont.Bold
.ColorIndex = SourceFont.ColorIndex
.FontStyle = SourceFont.FontStyle
.Name = SourceFont.Name
.Size = SourceFont.Size
.Underline = SourceFont.Underline
' Other properties ?
End With
Next SourceChar
DestChar = DestChar + Len(DELIM)

Next cell
Next cell1
End Sub

 

[DavidGMullins]

Thanks Tom, I was getting a Syntax Error at

Set DestRange = SourceCells.(1,3)(1)

I took a guess and changed this to "Set DestRange = SourceCells(1,3)
(1)", now the macro appropiately concatenates the two columns and
includes the character return, but it only preserves the rich text
formatting for the first cell (AC2). In my spreadsheet, Column AA has
Bold text, Column AB has normal text. Can you see where I've gone
wrong here? Thanks,

-David

 

[Guest]

Yes you caught my typo. Try it this way - worked for me with the situation
you described:

Sub PreserveRichText()

Dim SourceCells As Range
Dim DestRange As Range
Dim Cell As Range
Dim SourceChar As Long
Dim DestChar As Long
Dim SourceFont As Font
Const DELIM As String = vbCr


'Set SourceCells = Range("AA2:AB2")
'Set DestRange = Range("AC2")

Set r1 = Range(Range("G2"), Range("G2").End(xlDown))
For Each cell1 In r1
Set SourceCells = Cells(cell1.Row, "AA").Resize(1, 2)
Set DestRange = SourceCells(1, 3)(1)

DestRange.ClearContents


'Build the string first
For Each Cell In SourceCells
DestRange.Value = DestRange.Value & DELIM & Cell.Value
Next

DestRange.Value = Mid(DestRange.Value, Len(DELIM) + 1)

'Now process each Char
DestChar = 0 ' added line to reinitialize DestChar on each loop
For Each Cell In SourceCells
For SourceChar = 1 To Cell.Characters.Count
Set SourceFont = Cell.Characters(SourceChar, 1).Font
DestChar = DestChar + 1


With DestRange.Characters(DestChar, 1).Font
.Bold = SourceFont.Bold
.ColorIndex = SourceFont.ColorIndex
.FontStyle = SourceFont.FontStyle
.Name = SourceFont.Name
.Size = SourceFont.Size
.Underline = SourceFont.Underline
' Other properties ?
End With
Next SourceChar
DestChar = DestChar + Len(DELIM)

Next Cell
Next cell1
End Sub

 

[DavidGMullins]

Perfect. Works like magic. Thanks very much for this.

-David