Add String to next line of the same cell in LOOP

Question

I have this table which transposes cells based on value, if B2 = True then C2 copies to K2, J2 copies to L2 ELSE C2 copies to M2.

How do I make all ELSE conditions to write at the M column in the Row with the TRUE condition to the same cell adding on next line?

Here is the image, output of the code is green, and the yellow cell is what I wanted to happen.

Here is my initial code:

Public Sub SetCellValues()

Dim colB As Integer
Dim I As Integer
colB = Cells(Rows.Count, 2).End(xlUp).Row

For I = 2 To colB

    'If a match is found:
    If Worksheets("Sheet1").Cells(I, 2) = "User Story" Then
    ' Copy
        Worksheets("Sheet1").Cells(I, 11) = Worksheets("Sheet1").Cells(I, 3)
        Worksheets("Sheet1").Cells(I, 12) = Worksheets("Sheet1").Cells(I, 10)
    Else
    'Can we make all 'issue' titles line up in one cell at the 'user story' rows above it?
        Worksheets("Sheet1").Cells(I, 13) = Worksheets("Sheet1").Cells(I, 3)

    End If

Next I

End Sub

Answer 1

Something like this.

I declared the workbook as Worksheets("Sheet1"). -> ws. Makes it easier if you later want to change the worksheet name. You only need to change the name at one place. Also added a vertical alignment to make the layout more compelling.

Code:

Option Explicit

Public Sub SetCellValues()

Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")

Dim lrow_colB As Long
Dim lrow_colL As Long
Dim i As Long
lrow_colB = ws.Cells(Rows.Count, 3).End(xlUp).Row

For i = 2 To lrow_colB

    'If a match is found:
    If ws.Cells(i, 2) = "User Story" Then
    ' Copy
        ws.Cells(i, 11) = ws.Cells(i, 3)
        ws.Cells(i, 12) = ws.Cells(i, 10)
    Else
        lrow_colL = Cells(Rows.Count, 12).End(xlUp).Row 'Check for last row in Column L
        If ws.Cells(lrow_colL, 13).Value = "" Then ' If cell in column M is blank, copy C to M
            ws.Cells(lrow_colL, 13) = ws.Cells(i, 3)
        Else
            ws.Cells(lrow_colL, 13) = ws.Cells(lrow_colL, 13).Value & vbCrLf & ws.Cells(i, 3) 'If cell in column M is not blank, then combine with already existing cell value, use linebreak as delimiter
            ws.Range(Cells(lrow_colL, 1), Cells(lrow_colL, 13)).VerticalAlignment = xlVAlignCenter 'Align the cells to vertical
            'ws.Cells(lrow_colL, 13) = ws.Cells(lrow_colL, 13).Value & ", " & ws.Cells(i, 3) ''If cell in column M is not blank, then combine with already existing cell value, use comma as delimiter
        End If
    End If
Next i

End Sub

Answer 2

Write Multi Line

• Copy the complete code into a standard module (eg Module1 ).
• Carefully adjust the values in the constants section.
• Run only the Sub . The Function is called by the Sub .

The Code

Option Explicit

Sub writeMultiLine()

    ' Define constants.
    Const srcName As String = "Sheet1"
    Const srcRow1 As Long = 2
    Const srcCol1 As Long = 2
    Const srcCol2 As Long = 3
    Const srcCol3 As Long = 10
    Const tgtName As String = "Sheet1"
    Const tgtFirstCell As String = "K2"
    Const Criteria As String = "User Story"
    Dim Separator As String: Separator = Chr(10)
    Dim wb As Workbook: Set wb = ThisWorkbook

    ' Write values from Source Columns to Source Arrays.
    Dim ws As Worksheet: Set ws = wb.Worksheets(srcName)
    Dim Source(2) As Variant
    Source(0) = getColumnValues(ws, srcCol1, srcRow1)
    If IsEmpty(Source(0)) Then Exit Sub
    Dim ubS As Long: ubS = UBound(Source(0))
    Source(1) = ws.Cells(srcRow1, srcCol2).Resize(ubS)
    Source(2) = ws.Cells(srcRow1, srcCol3).Resize(ubS)
    Set ws = Nothing

    ' Write values from Source Arrays to Target Array.
    Dim Target As Variant: ReDim Target(1 To ubS, 1 To UBound(Source) + 1)
    Dim i As Long, k  As Long, Current As String
    For i = 1 To ubS
        If Source(0)(i, 1) = Criteria Then
            Target(i, 1) = Source(1)(i, 1)
            Target(i, 2) = Source(2)(i, 1)
            If i < ubS Then
                GoSub buildString
            End If
        End If
    Next i

    ' Write values from Target Array to Target Range.
    Set ws = wb.Worksheets(tgtName)
    ws.Range(tgtFirstCell).Resize(ubS, UBound(Target, 2)) = Target

    ' Inform user.
    MsgBox "Data copied.", vbInformation, "Success"

    Exit Sub

buildString:
    k = i + 1
    Current = Source(0)(k, 1)
    If Current = Criteria Then Return
    k = k + 1
    Do Until k > ubS
        If Source(0)(k, 1) <> Criteria Then
            Current = Current & Separator & Source(0)(k, 1)
            k = k + 1
        Else
            Exit Do
        End If
    Loop
    Target(i, 3) = Current
    i = k - 1
Return

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values of a non-empty one-column range starting     '
'               from a specified row, to a 2D one-based one-column array.      '
' Returns:      A 2D one-based one-column array.                               '
' Remarks:      If the column is empty or its last non-empty row is above      '
'               the specified row or if an error occurs the function will      '
'               return an empty variant. Therefore the function's result       '
'               can be tested with "IsEmpty".                                  '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnValues(Sheet As Worksheet, _
                         Optional ByVal AnyColumn As Variant = 1, _
                         Optional ByVal FirstRow As Long = 1) _
        As Variant

    On Error GoTo exitProcedure
    Dim rng As Range
    Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Function
    If rng.Row < FirstRow Then Exit Function
    Set rng = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)

    Dim Result As Variant
    If rng.Rows.Count = 1 Then
        ReDim Result(1 To 1, 1 To 1): Result(1, 1) = rng.Value
    Else
        Result = rng.Value
    End If
    getColumnValues = Result

exitProcedure:
End Function