VBA Conditional concatenate of a group of cells in two columns

Question

This is far to advanced for me to figure out. Here is an example of the worksheet layout:

Row#    ColA    ColB                                 
23      7       Description 
24      8       Description 
25      
26              For cases with  
27              SpecialOptionDesc = Yes
28      9       Description 
29      
30              For cases with  
31              SomeOptionDesc = Yes
32              and 
33              AnotherOptionDesc = No
34      9       Description 
35      
36      10      Description

I'm need to consolidate the information in ColB when the them "For cases with" appears, with the cells below it. The information needs to end up on the row that has the identifying number in ColA. So in this case ColB Rows 26, 27, 28, will all be "copied" or whatever into ColB row 28. Likewise, ColB Rows 30 though 34 will all be on ColB row 34. The old rows (26, 27, 30, 31, 33) can be deleted mashed together or whatever. No data on those rows will be needed any longer.

Michael Kingsmill Michael Kingsmill · Accepted Answer · 2012-02-03T19:53:40

I didn't actually compile this and try it Excel, but I think that it will get you 90% of the way there if not all the way. I am stepping away from the computer for a bit, but will do some testing when I get back.

Dim cellValue As String
Dim i As Integer
Dim j As Integer
Dim strResult As String

Const endRow As Integer = 500

For i = 1 To endRow
     If LCase(ActiveSheet.Cells(i, 2).Value) = "for cases with" Then
        j = 0
        strResult = ""

        While ActiveSheet.Cells(i + j, 1).Value = "" And i + j < endRow
            strResult = strResult + " " + ActiveSheet.Cells(i + j, 2).Value

            ' delete stuff after using
            ActiveSheet.Cells(i + j, 2).Value = ""

            j = j + 1
        Wend

        ActiveSheet.Cells(i + j, 2) = strResult + " " + ActiveSheet.Cells(i + j, 2)
     End If
Next i

VBA Conditional concatenate of a group of cells in two columns

1 Answers