Combine text in multiple cells macro

[youremyboyblue]

I need help creating a macro that will loop through thousands of rows of text and combine the text that is separated by an empty row above and below into one cell. For example, rows 1-5 would be combined into one cell, rows 7-12 would be combined into one cell, rows 14-15 would be combined into one cell, and rows 17-19 would be combined into one cell.

All of the text is in column A but it extends for approximately 40,000 rows. The combined text can be inserted into another column or into another workbook. The old text doesn't need to be deleted necessarily (although it wouldn't matter if it was) and the new text doesn't need to have a blank row between each row of combined text (although it wouldn't matter if it was).

Can this be accomplished with a macro?


Excel 2010
<TABLE style="BORDER-BOTTOM: #bbb 1px solid; BORDER-LEFT: #bbb 1px solid; BACKGROUND-COLOR: #ffffff; BORDER-COLLAPSE: collapse; BORDER-TOP: #bbb 1px solid; BORDER-RIGHT: #bbb 1px solid" rules=all cellPadding=2><COLGROUP><COL style="BACKGROUND-COLOR: #dae7f5" width=25><COL></COLGROUP><THEAD><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #dae7f5; COLOR: #161120"><TH></TH><TH>A</TH></TR></THEAD><TBODY><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">1</TD><TD>Lorem ipsum dolor sit amet, consectetur adipisicing elit, </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">2</TD><TD>sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">3</TD><TD>Ut enim ad minim veniam, </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">4</TD><TD>quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">5</TD><TD>Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">6</TD><TD style="TEXT-ALIGN: right"></TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">7</TD><TD>Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur?</TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">8</TD><TD>Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"</TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">9</TD><TD>Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">10</TD><TD>sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">11</TD><TD>Nemo enim ipsam voluptatem quia voluptas </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">12</TD><TD>sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt.</TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">13</TD><TD style="TEXT-ALIGN: right"></TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">14</TD><TD>Sed ut perspiciatis unde omnis</TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">15</TD><TD>beatae vitae dicta sunt explicabo. </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">16</TD><TD style="TEXT-ALIGN: right"></TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">17</TD><TD>Iste natus error sit voluptatem accusantium doloremque laudantium, </TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">18</TD><TD>totam rem aperiam,</TD></TR><TR><TD style="TEXT-ALIGN: center; COLOR: #161120">19</TD><TD>eaque ipsa quae ab illo inventore veritatis et quasi architecto.</TD></TR></TBODY></TABLE>

text​

 

[Sahak]

Hi youremyboyblue,

Try this

Sub Macro1()
    Dim TxtCll As Range
    Dim Cnt As Double
    Cnt = WorksheetFunction.CountA(Range("B:B"))
    For Each TxtCll In Range("A1:A40000")
        If TxtCll <> "" Then Range("B1").Offset(Cnt, 0).Value = Range("B1").Offset(Cnt, 0).Value & " " & TxtCll
        If TxtCll = "" Then Cnt = Cnt + 1
    Next
End Sub

 

[youremyboyblue]

Sahak-

Thank you very much for your reply. The macro worked perfectly. I appreciate your help and wouldn't have been able to do it without you.

The next portion of this project is to sum up the number of words of different authors. Each author's text is written in a different color, with some cells containing multiple colors (when one cell has two authors, it will contain text with two different colors). I know how to sum up the words for each cell by using the len(a1)-len(substitute(a1," ",""))+1 formula, but is there a way to get it to sum word count by color?

Thanks again for your help!

 

[Sahak]

I’m sorry, I don’t know how to get sum of words by color (I’m sure Excel guru’s will know), but I can give you code how count colored cells, it can give you some idea.

Copy this function in a module

Function CountColor(Rng As Range, FontColor As Range) As Integer
    Dim TxtCll  As Range
    Dim FntClr As Long
    FntClr = FontColor.Range("A1").Font.Color
    For Each TxtCll In Rng
        If TxtCll.Font.Color = FntClr Then
            CountColor = (CountColor + 1)
        End If
     Next TxtCll
End Function

use this formula in your sheet

=CountColor(A1:A40000,C1)

Where C1 has the Font Color format that you want to count