CODEWITHSUNDEEP
vbaexcel
Sampson
Sampson

Reputation: 13

Find Text within Range and Insert New Line

I've had a few ideas about tackling this issue, but it's the linking of the two separate functions which I don't know how to process together in VBA. I'd like the code to find cells which are not blank within a range and to insert a new line with its respective data. Example:

    No  a   b   c   d   q1     q2       q3       q4     q5
    1   X   X   X   X          poor     rubbish     
    2   Y   Y   Y   Y          excellent         great

The data can appear anywhere from between q1 and q5, and I would like VBA to separate each response from q1 - q5 with an individual line. Therefore I assume that I would need a loop function to look between q1 and q5 to find out if the cells are not blank, and from this I would like the new line separate each of the responses with their own line, but I'm not sure how to tell VBA to leave 'poor' under q2 and look for the next non blank and take that non blank and insert a new line (So 'rubbish' should be taken to the new line, but deleted from it's original line so that 'poor' can have it's own independent line).

The end result should look like this:

   No   a   b   c   d   q1     q2       q3       q4     q5
    1   X   X   X   X          poor             
    1   X   X   X   X                   rubbish     
    2   Y   Y   Y   Y          excellent        
    2   Y   Y   Y   Y                            great

Upvotes: 0

Views: 110

Answers (1)

Lance
Lance

Reputation: 203

Hope this one helps a bit

Sub Sorter()
    Dim xrow As Integer
    Dim xcolumn As Integer
    Dim firstword As Boolean

    xrow = 2
    firstword = True

    Do
        xcolumn = 6
        Do
            If Cells(xrow, xcolumn).Value <> "" Then 'if not empty then
                If firstword = True Then 'checks if it is first time word is present in cell
                    firstword = False 'if true then set it to false for next one
                Else
                    Cells(xrow + 1, xcolumn).EntireRow.Insert 'if its not the first occasion then insert row beneath
                    Cells(xrow + 1, xcolumn).Value = Cells(xrow, xcolumn).Value 'rewrite the value
                    Cells(xrow, xcolumn).ClearContents 'and delete the original
                    Range(Cells(xrow + 1, 1), Cells(xrow + 1, 5)).Value = Range(Cells(xrow, 1), Cells(xrow, 5)).Value 'copy the head of the original
                End If
            End If
            xcolumn = xcolumn + 1 'advance one column further
        Loop Until xcolumn = 11 'specified by user, probably last question which is 10th column for me
        xrow = xrow + 1 'advance one row further
        firstword = True
    Loop Until Cells(xrow, 1) = "" 'will loop until there is no remaining head in column 1 also can be specified as "until xrow=maxrow
    End Sub

Upvotes: 1

Related Questions