Concatenate Cells between blank rows

[mattmagoo]

Hi,

I'm trying to Concatenate text from cells in a column that are separated by blanks.

I've had some success with doing this for single columns, but what I want to do is create a kind of driver column, from which the rules for blank rows is identified, and then apply the concatenation to a number of cells in a selected range.

In the attached ("Original" Sheet) I've got the key data in column D, which will drive the concatenation rule, but I also need A, B, E and F to be concatenated as A and B line up with the top of the data in D, whereas E and F line up with the bottom of the data in D.

Sometimes they will align like this, other times the data in E will be center to the data in D,

Any starting points would be a great help, as I can't seem to get over applying the rule to multiple columns,

Thanks

[JOHN H. DAVIS]

Does this help?

Sub mattmagoo()
Dim i As Long, y As Long
y = Range("D" & Rows.Count).End(3).row
Range("D2:D" & y).SpecialCells(4).EntireRow.Delete
For i = y To 2 Step -1
    If Cells(i, "D").Font.Underline = xlUnderlineStyleSingle Then GoTo zz
    If Cells(i, "A") = "" Then
        Cells(i - 1, "D") = Cells(i - 1, "D") & " " & Cells(i, "D")
        Range(Cells(i, "E"), Cells(i, "F")).Cut Cells(i - 1, "E")
        Rows(i).Delete
    End If
zz:
Next i
End Sub

[mattmagoo]

Hi John,

Thanks for your help,

The logic seems to be running off whether or not there is a blank in Row A, ideally I need it to run off the blanks in Row D and delete them right at the end, as sometimes A is blank,

Matt

[JOHN H. DAVIS]

Did you test it on your sample. The logic handles Column D as well.

[mattmagoo]

It doesn't concatenate the data in rows 5 & 6 as there is no corresponding data in A (even after the underline rule is removed)

[JOHN H. DAVIS]

Try:

Sub mattmagoo()
Dim i As Long, y As Long
y = Range("D" & Rows.Count).End(3).row
For i = y To 2 Step -1
    If Cells(i, "D").Font.Underline = xlUnderlineStyleSingle Then
        If Cells(i - 1, "D").Font.Underline = xlUnderlineStyleSingle Then
            Cells(i - 1, "D") = Cells(i - 1, "D") & " " & Cells(i, "D")
            Cells(i, "D").ClearContents
        End If
    End If
Next i
Range("D2:D" & y).SpecialCells(4).EntireRow.Delete
For i = y To 2 Step -1
    If Cells(i, "D").Font.Underline = xlUnderlineStyleSingle Then GoTo zz
    If Cells(i, "A") = "" Then
        Cells(i - 1, "D") = Cells(i - 1, "D") & " " & Cells(i, "D")
        Range(Cells(i, "E"), Cells(i, "F")).Cut Cells(i - 1, "E")
        Rows(i).Delete
    End If
zz:
Next i
End Sub

Note: Underline readded.

[jindon]

Try this.

Sub test()
    Dim x, r As Range
    Application.ScreenUpdating = False
    x = Application.Match("description", Rows(1), 0)
    If (IsNumeric(x)) * (Columns(x).SpecialCells(2).Areas.Count > 1) Then
        With Range(Cells(1, x), Cells(Rows.Count, x).End(xlUp))
            For Each r In .SpecialCells(2, 2).Areas
                If r.Count > 1 Then
                    r(1).Characters(Len(r(1)) + 2, Len(r(2))).Text = " " & r(2)
                    r(2).Clear
                    r(2, 2).Resize(, 2).Copy r(, 2)
                End If
            Next
            .SpecialCells(4).EntireRow.Delete
        End With
    End If
    Application.ScreenUpdating = True
End Sub