excel - 根据标准复制多个单元格并将它们全部打印到一个单元格上

Question

基本上我想使用 vba 根据标准复制多个单元格并将所有信息粘贴到另一个工作表中的一个单元格上。我希望将它们粘贴到一个单元格中。

我想做的代码是，如果 D 列中的值为“红色”，我想从 D 中的值为“红色”的特定行复制 A 列和 B 列的信息，然后粘贴整个信息仅作为组合信息放在一个单元格上。我还想要一个循环来为每一行执行此操作，然后再次将该信息粘贴到一个单元格上，而不会从 D 列仍为“红色”的前一行中删除先前粘贴的信息。

我知道我必须使用一个循环来检查 D 中的每一行或每个单元格，然后使用一个 If 语句来检查它是否显示为红色，然后从 D 列复制偏移量，但我不确定如何粘贴所有该信息仅在一个单元格上。我尝试过使用其他信息来源，但我有点卡住了。这可能是微不足道的，但我对 vba 比较陌生。

这些是 4 列的样子。

1.a A3-1B   R   red

2.c A8-2G   R   red

3.f B2-2E   B   blue

4.b A4-B8   B   blue

5.a A7-B10  R   red

6.c A4-C7   G   green

7.b D9-VB   Y   yellow

最后，我希望仅一个单元格中的过滤信息如下所示：

a A3-1B

c A8-2G

a A7-B10

我只包含了一个简单的代码，我知道它与我需要的相去甚远。因为它只复制来自 B 的信息以及这个循环是如何形成的，所以它只会给我最后一行的信息。

Sub sort2()

    Dim SingleCell As Range
    Dim ListOfCells As Range

    Set ListOfCells = Range("D2", Range("D2").End(xlDown))

    For Each SingleCell In ListOfCells

        If SingleCell.Value = "red" Then

            SingleCell.Offset(0, 2).Copy

        End If

        Worksheet.Add
        Range("A1").PasteSpecial

    Next SingleCell

End Sub

标签： excelvba

Answer 1

这是基于我理解的解决方案。希望它为您提供额外的策略，您可以在其他 VBA 中使用。

Sub DoStuff()

    '' Set Source and Target Sheets
    Dim srcSheet As Worksheet
    Set srcSheet = ThisWorkbook.Worksheets("Source") '' Source Data store on sheet called Source

    Dim targetSheet As Worksheet
    Set targetSheet = ThisWorkbook.Worksheets("Result") '' Sheet where I want to store results

    Dim SingleCell As Range
    Dim ListOfCells As Range

    Set ListOfCells = srcSheet.Range("D2", srcSheet.Range("D2").End(xlDown))

    Dim foundColor As Range
    Dim nextAvailableCell As Range

    For Each SingleCell In ListOfCells

        'If SingleCell.Value = "red" Then
        '    SingleCell.Offset(0, 2).Copy
        'End If

        'Worksheet.Add
        'Range("A1").PasteSpecial

        '' Find where the current color is on targetSheet in column A
        '' Find result must be a whole cell match ie red doesn't match red-orange
        Set foundColor = targetSheet.Range("A:A").Find(what:=SingleCell.Value, lookat:=xlWhole)

        '' If it found a cell with that color append it to the existing text
        If Not foundColor Is Nothing Then
            '' the new value is the current value PLUS a new line PLUS the appending text
            '' using .Value method skips the clipboard and is much faster than copy/paste
            foundColor.Offset(0, 1).Value = foundColor.Offset(0, 1).Value & _
                                            vbCrLf & _
                                            SingleCell.Offset(0, -3).Value & " " & _
                                            SingleCell.Offset(0, -2).Value

        '' Otherwise create a new "Entry"
        Else
            '' Get the first available (blank) row
            '' ASSUMING NO HEADERS NEEDED ON RESULT SHEET
            '========================
            If targetSheet.Cells(1, 1).Value = "" Then
                Set nextAvailableCell = targetSheet.Cells(1, 1)
            Else
                Set nextAvailableCell = targetSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
            '========================

            '' Copy the Info
            nextAvailableCell.Value = SingleCell.Value
            nextAvailableCell.Offset(0, 1).Value = SingleCell.Offset(0, -3).Value & " " & _
                                                   SingleCell.Offset(0, -2).Value

        End If

    Next SingleCell


End Sub