How to fill macro down ?

**smiso24** · 02-11-2012, 09:54 PM

I'd like to know how to fill the following macro down several thousand rows...I found the macro online but when I run it, it only fills the first row...Sorry if this is an obvious question but I'm a noob when it comes to macros....

Sub MG08Sep16
Dim Rng As Range, Dn As Range, col As String, Csp, Txt As String
Dim c As Integer, St As Integer
 Set Rng = Range("A1:C1")
For Each Dn In Rng
    col = col & Dn.Font.ColorIndex & "," & Len(Dn) + 1 & ","
    Txt = Txt & Dn.Value & " "
Next Dn
    Range("D1") = Txt
        Csp = Split(col, ",")
For c = 0 To UBound(Csp) - 1 Step 2
    If c = 0 Then St = 1 Else St = St + Csp(c - 1)
        Range("D1").Characters(St, Csp(c)).Font.ColorIndex = Csp(c)
Next c
End Sub

**Palmetto** · 02-11-2012, 10:54 PM

Code tags are requird when posting VBA code, per forum rules ( you did read them, right?).

Please edit your post to add the code tags, which are used like so:

code between these tags

After you correct your post, someone will chip in and help.

**smiso24** · 02-11-2012, 11:01 PM

Originally Posted by Palmetto

Code tags are requird when posting VBA code, per forum rules ( you did read them, right?).

Please edit your post to add the code tags, which are used like so:

[code]
code between these tags
[/code]

After you correct your post, someone will chip in and help.

I'm sorry but I don't understand what a code tag is. I copied and pasted the entire code as I found it. I apologize for my ignorance but I really don't know much about macros...

**jaslake** · 02-11-2012, 11:22 PM

Hi smiso24

To add Code Tags (Rule #3).

To edit your post, go to post #1, press Edit Post, press Go Advanced to see the [#] button). Highlight your code then press the [#] button. Press Save Changes. The result will appear like this in the post window:

your code here ...
and here ...
and here

**smiso24** · 02-11-2012, 11:58 PM

Thank you for the clarification.

**protonLeah** · 02-12-2012, 12:15 AM

You need to describe your workbook (better to post a sample). However, the line Set Rng = Range("A1:C1")
sets the range as three cells A1,B1,C1 ---> the first row.
In order to expand Rng to include all rows you need something like:

Set Rng = Range("A1:C" & Cells(Rows.Count, "A").End(xlup).Row)

**smiso24** · 02-12-2012, 01:12 AM

I've included a sample worksheet. I'd like to concatenate cells B1:D1 and put the result in cell E1 while preserving the color scheme of the individual cells. I actually have roughly 1700 rows of data and would like to do this for each row. Hope I explained it okay...

**protonLeah** · 02-12-2012, 06:58 PM

Works on cells from A1:Cn, putting the concatenated string in column D of the same row

Sub CellsToString()
    Dim WorkRange   As Range, _
        Cell        As Range, _
        Ndx         As Long, _
        RowPtr      As Long, _
        StartPos    As Long, _
        WordLength  As Long, _
        TextColor   As Long, _
        LastRow     As Long, _
        FontData    As Variant, _
        FontDataStr As String, _
        NewString   As String, _
        comma       As String
        
    ' get the last row in column A
    LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    
    ' loop through the rows
    For RowPtr = 1 To LastRow
        NewString = ""
        FontDataStr = ""
        comma = ""
        
        'set the new workrange from column A to C of the current row
        Set WorkRange = Range(Cells(RowPtr, "A"), Cells(RowPtr, "C"))
        
        For Each Cell In WorkRange
            'copy the font color index and word length
            FontDataStr = FontDataStr & comma & Cell.Font.ColorIndex & "," & Len(Cell) + 1
            
            'build the new text string from the cells in the current work range
            NewString = NewString & Trim(Cell.Value) & " "
            comma = ","
        Next Cell
        
        'strip any trailing spaces
        Cells(RowPtr, "D").Value = Trim(NewString)
        FontData = Split(FontDataStr, ",")
        StartPos = 1
        
        'step through each word in the string and apply the colors from the parent cell
        For Ndx = 0 To UBound(FontData) - 1 Step 2
            WordLength = FontData(Ndx + 1)
            TextColor = FontData(Ndx)
            Cells(RowPtr, "D").Characters(StartPos, WordLength).Font.ColorIndex = TextColor
            
            'step to the next word in the string
            StartPos = StartPos + WordLength
        Next Ndx
    Next RowPtr
End Sub