Question

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

我想编写的代码是，如果D列中的值是“红色”，我想从D值是“ red”的特定行中复制A列和B列的信息，并将整个信息粘贴为仅一个单元格作为组合信息。我还希望有一个循环，对每一行都执行一次，然后再次将该信息粘贴到一次单元格上，而不从D列仍为“红色”的上一行删除先前粘贴的信息。

我知道我将不得不使用一个循环，该循环将检查D中的每一行或每个单元格，然后使用If语句，该语句将检查它是否表示Red，然后从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

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

根据条件复制多个单元格并将它们全部打印到一个单元格上

1 个答案: