Vba 如果三列之间包含特定值，则复制粘贴

我想知道如何以最好的方式使用“工作表更改”。现在我用它在两张不同的纸上从一列复制到另一列。每当更新表1中的列时，表2中的列也将更新。使用两列是没有问题的，代码工作正常

我的问题是每当我想使用三列时。我想让它在A列中循环，当它在A列中找到“橙色”这个词时，它应该将B列复制到sheet2中的coulmn A。有关更多详细信息，请参阅我的工作表

如果发现橙色，则只应将B列中的值“1,3,6”复制并更新到表2中的A列

我试过一段代码，但没有成功，它将所有内容复制到了B列。如果可以使用VLOOKUP，我该怎么做？因为我试过了，但每次换手机时都不会更新

Dim x As Range
With Sheets("Sheet1")
Set x = .Columns(1).Find("Orange", LookIn:=xlValues, lookat:=xlWhole)
    If Not x Is Nothing Then
        .Columns(2).Copy Sheets("Sheet2").[B1]
    End If
Set x = Nothing
End With

例如：

工作手册1： A列

橙色的

苹果

橙色的

梨

浆果

橙色的

B栏：

一,

二,

三,

四,

五,

六,

应填充到新的工作表中，其中B列工作表2中仅粘贴了“1,3,6”

请尝试以下操作：

Sub Fruity()
Application.ScreenUpdating = False
    Dim LastRow As Integer
    'Search code
    LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    Dim i As Long


For i = 1 To LastRow

   If ThisWorkbook.Sheets("Sheet1").Range("A" & i) = "Orange" Then
        Set NextCell = ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp)
        If NextCell = "" Then
            NextCell = ThisWorkbook.Sheets("Sheet1").Range("B" & i)
        Else
            NextCell.Offset(1) = ThisWorkbook.Sheets("Sheet1").Range("B" & i)
        End If
    End If


Next i

Application.ScreenUpdating = True

End Sub

我不确定你改变工作表的目标是什么，所以你必须澄清你的问题或自己补充

---

*编辑：现在将Sheet1中的B列值从B1开始放入Sheet2中的B列，而不是放入与找到的“橙色”对应的行中。

我认为使用

工作簿\u SheetDeactivate

事件会更好地为您服务。通过使用此事件（仅当用户从源工作表中选择一个工作表时），您仅执行一次复制。作为替代和/或补充，您可以从

工作簿\u BeforeSave

事件执行相同的复制（以防用户保存和退出工作簿而不更改工作表）

---

谢谢你的魅力！但是有没有可能这些数字从B1开始，填充为一个列表，中间没有空单元格？如果在A1列中找不到橙色，但在coulmn A2中，它仍应在B1列中打印，而不是B2列中打印。

Option Explicit

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    Dim activeRange As Range
    Dim lastRow As Long
    Dim c As Range

    If Sh.Name = "Sheet1" Then
        lastRow = Sh.Range("A" & Rows.Count).End(xlUp).Row
        Set activeRange = Sh.Range("A1:A" & lastRow)
        For Each c In activeRange
            If c.Value = "Orange" Then
                Sheets("Sheet2").Range(c.Offset(0, 1).Address) = c.Offset(0, 1).Value
            End If
        Next c
        Debug.Print "done"
    End If
End Sub