Concatenate cells in a column until blank cell

[McQuinge]

Hi!

I'm a newbie in vba, and got stucked with concatenating cells.
I'm using excel 2010 english version SP1.

Is there a way to concatenate cells until it meet a blank cell, and then start on the blank cell and concatenate cells until it meet a new blank cell? (using vba)

I have a report that is brought out of a system and saved as a workbook. My problem is that the report contains lot of text that is separated into cells in a column. At the moment the column contains 40.000 cells with text.

I will try to give you an example:
If you have a lyric that is splitted into verses, this is how my original report looks like. When I get this in a excel file, the verse is separated into cells, where each line get one cell.
And between the verses there is a blank cell.
The number of cells are not constant because the verses are not the same size or same amount of lines.

Original report:
Yesterday, all my troubles seemed so far away.
Now it looks as though they're here to stay.
Oh, I believe in yesterday.

Suddenly,
I'm not half the man I used to be,
There's a shadow hanging over me,
Oh, yesterday came suddenly.

Excel result:
A1: BLANK
A2: Yesterday, all my troubles seemed so far away.
A3: Now it looks as though they're here to stay.
A4: Oh, I believe in yesterday.
A5: BLANK
A6: Suddenly,
A7: I'm not half the man I used to be,
A8: There's a shadow hanging over me,
A9: Oh, yesterday came suddenly.
A10: BLANK

My Wish:
A1: Yesterday, all my troubles seemed so far away. Now it looks as though they're here to stay. Oh, I believe in yesterday.
A2: (NOT IMPORTANT, maybe delete row after A1 is complete)
A3: (NOT IMPORTANT, maybe delete row after A1 is complete)
A4: (NOT IMPORTANT, maybe delete row after A1 is complete)
A5: Suddenly, I'm not half the man I used to be, There's a shadow hanging over me, Oh, yesterday came suddenly.
A6: (NOT IMPORTANT, maybe delete row after A5 is complete)

Thanks for reading.
Hoping you can give me a clue!

 

[MickG]

Try this:-
NB:- If you don't want a blank row between lines, Remove the second :- c = c+1

[COLOR="Navy"]Sub[/COLOR] MG23Jan14
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    ReDim Ray(1 To Rng.Areas.Count * 2)
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
            c = c + 1
            Ray(c) = Join(Application.Transpose(Dn), " ")
            c = c + 1
        [COLOR="Navy"]Next[/COLOR] Dn
            '[COLOR="Green"][B]Change "F1" to "A1" to overwrite Data if required[/B][/COLOR]
            Range("F1").Resize(c) = Application.Transpose(Ray)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[jim may]

Here you go... Running Macro (Below) produces the Data in Column C

Excel Workbook
	A	B	C
1		SELECT RANGE FIRST
2	Yesterday, all my troubles seemed so far away.	Range(A2:A14)	Yesterday, all my troubles seemed so far away. Now it looks as though they're here to stay. Oh, I believe in yesterday.
3	Now it looks as though they're here to stay.		Suddenly, I'm not half the man I used to be, There's a shadow hanging over me, Oh, yesterday came suddenly.
4	Oh, I believe in yesterday.		I just added another verse which is not a part of the original But it is needed for testing purposes Woohoo
5
6	Suddenly,
7	I'm not half the man I used to be,
8	There's a shadow hanging over me,
9	Oh, yesterday came suddenly.
10
11	I just added another verse
12	which is not a part of the original
13	But it is needed for testing purposes
14	Woohoo
Sheet1

Excel 2007

Sub Foo()
Dim w As Long
Dim t As String
Dim Rng As Range, c As Range
w = 1
Set Rng = Selection
        For Each c In Rng
            If c<> "" Then
            t = t & c & " "
            Else
            w = w + 1
            t = Left(t, Len(t) - 1)
            Cells(w, 3).Value = t
            t = ""
            End If
        Next c
    w = w + 1
    t = Left(t, Len(t) - 1)
    Cells(w, 3).Value = t
End Sub

 

[McQuinge]

Hi MickG!

Thanks for the respons!

I don't understand your code, and it fails on the line

Ray(c) = Join(Application.Transpose(Dn), " ")

"type mismatch"

I tried it in a test sheet and then it worked well.
I will use some more time to find out what the problem is...

The result I tried to place in the blank cells at the same column, but I clearly can't read your code.

Here's my try:

Sub MG23Jan14()
Dim Rng As Range
Dim Dn As Range
Dim c As Long
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    ReDim Ray(1 To Rng.Areas.Count * 2)
        For Each Dn In Rng.Areas
            c = c + 1
            Ray(c) = Join(Application.Transpose(Dn), " ")
            Next Dn
            'Change "F1" to "A1" to overwrite Data if required
            Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks) = Application.Transpose(Ray)
End Sub

Regards
McQuinge

 

[MickG]

It possibly failed because you have a single row with text as opposed to a number of rows.
Try this:-
This will overwrite column "A".

[COLOR="Navy"]Sub[/COLOR] MG23Jan18
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    ReDim ray(1 To Rng.Areas.Count * 2)
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
            c = c + 1
           [COLOR="Navy"]If[/COLOR] Dn.Rows.Count > 1 [COLOR="Navy"]Then[/COLOR]
                ray(c) = Join(Application.Transpose(Dn), " ")
            [COLOR="Navy"]Else[/COLOR]
                ray(c) = Dn
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dn
            Columns("A:A").ClearContents
            Range("A1").Resize(c) = Application.Transpose(ray)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[McQuinge]

Hi MickG

I have found the reason why the code failed at the start, it doesn't manage if there is only one cell with text and then a blank cell.

The other issue is that it seems to be a limitations to how many characters the code could handle in one "verse". Seems to be 242 characters.

And of course this is my problem because I not included this in my question at start.

So for the moment I fix this manually.
Thanks for the help!

I will also try the other code from Jim May to see how that works!

 

[McQuinge]

Hi Jim May!
Thanks for your respond.

It look likes your code is working well.
Is it possible to make the code so it could remember the blank cell and put the result there instead of in column C?

As shown in "My Wish".

Thanks

 

[jim may]

Poof!!! You are Granted ONLY 2 more Wishes; LOL

Replace previous code with:

Sub Foo()
Dim w As Long
Dim t As String
Dim Rng As Range, c As Range
'w = 1
Set Rng = Selection
        For Each c In Rng
            If c <> "" Then
            t = t & c & " "
            Else
            'w = w + 1
            t = Left(t, Len(t) - 1)
            c.Value = t
            t = ""
            End If
        Next c
    w = w + 1
    t = Left(t, Len(t) - 1)
    Cells(w, 3).Value = t
End Sub

 

[jim may]

Woops, I failed to CHANGE the Below -- Give me a minute (which means 10)...

Next c
w = w + 1
t = Left(t, Len(t) - 1)
Cells(w, 3).Value = t

 

[jim may]

OK, Try this!! (Replacement of previous code)

Sub Foo()
Dim w As Long
Dim t As String
Dim Rng As Range, c As Range
'w = 1
Set Rng = Selection
        For Each c In Rng
            If c <> "" Then
            t = t & c & " "
            Else
            'w = w + 1
            t = Left(t, Len(t) - 1)
            c.Value = t
            t = ""
            End If
        Next c
    'w = w + 1
    t = Left(t, Len(t) - 1)
    Lr = Rng.Offset(Rng.Rows.Count).Row
    Range("A" & Lr).Value = t
End Sub