Question

目前，我有从A到AB的专栏。我想实现一个结果，如果任何单元格在一行的Y列：AB中更新，单元格（列A和Y：行的AB）将被复制并粘贴到名为Sheet2的新工作表中，进入A列到即

我的代码目前可以执行上述操作，但是当我在列Y到AB中逐个更改所有4个值时，将生成4行，以反映所做的每个更改。例如。要复制的第一行反映了在Y列中所做的更改。复制的第二行反映了在Z列中所做的更改。复制的第三行反映了在AB列中所做的更改。等等。

我只需要将一行复制到Sheet 2上，该行反映了Sheet 1中一行Y列到AB列的所有更改。有没有办法这样做？

我对VBA并不熟悉，所有指导都非常感谢！谢谢

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Columns("Y:AB")) Is Nothing Then Exit Sub

Range("Y" & Target.Row, "AB" & Target.Row).Copy Sheets("Sheet2").Range("B" & Rows.count).End(xlUp).Offset(1, 0)
Range("A" & Target.Row).Copy Sheets("Sheet2").Range("A" & Rows.count).End(xlUp).Offset(1, 0)

End Sub

Answer 1

试试这个：

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo halt
    Application.EnableEvents = False
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
    With sh1
        If Intersect(Target, .Range("Y:AB")) Is Nothing Then GoTo forward
        Dim trow As Long, drow As Long, rng As Range
        trow = Target.Row
        Set rng = sh2.Range("A:A").Find(.Range("A" & trow).Value, sh2.Range("A1"))
        If rng Is Nothing Then
            drow = sh2.Range("A" & .Rows.Count).End(xlUp).Row + 1
            sh2.Range("A" & drow) = .Range("A" & trow)
        Else
            drow = rng.Row
        End If
        .Range("Y" & trow, "AB" & trow).Copy sh2.Range("B" & drow)
    End With
forward:
    Application.EnableEvents = True
    Exit Sub
halt:
    MsgBox Err.Description
    Resume forward
End Sub

我假设 A列包含唯一标识符。
因此，上面的代码执行您描述的内容以及您在评论中解释的内容。 HTH。

VBA：工作表更改导致多个复制和粘贴的数据

1 个答案: