将字符串添加到LOOP中同一单元格的下一行。

Posted 2021-04-12

我有这样一个表格，它是根据值来转换单元格的，如果B2=True，那么C2复制到K2，J2复制到L2 ELSE C2复制到M2。

如何使所有ELSE条件写在M列的行中，TRUE条件写在同一单元格的下一行添加？

下面是图片，输出的代码是绿色的，黄色的单元格是我想发生的。

这是我最初的代码。

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

答案

类似这样的。

我把工作簿声明为 Worksheets("Sheet1"). -&gt。ws.使你以后想改变工作表名称时更容易。你只需要在一个地方改变名称.还增加了一个垂直排列，使布局更加引人注目。

代码。

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

另一答案

编写多行

• 将完整的代码复制到一个标准的模块中(如 Module1).
• 仔细调整常量部分的值。
• 只运行 Sub. 该 Function 是由 Sub.

守则

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