从同一行复制值但其他列（可变偏移量）Excel VBA

Question

下面的代码确保范围（“D16：E25”）中只有一个单元格可以包含任何值，当在此范围内的其他单元格之一中输入任何值/字符串时，代码会删除所有其他。 （这部分工作正常，感谢“Macro Man”）

现在我希望代码从 B 列的某个单元格中复制（并粘贴到“B5”）一个值，这需要是与范围中的值位于同一行的单元格（“D16 :E16")。 尝试了您可以在下面找到的以下代码......但它没有用。 有人知道解决方案吗？ 我希望工作簿（单元格“B5”）自动更新，因此无需运行宏或按下按钮。

If Not Intersect(Target, Range("D16:E25")) Is Nothing Then
    If Target.Cells.Count > 1 Then
        MsgBox "Please edit one cell at a time!"
    Else
        Application.EnableEvents = False

        newVal = Target.Value
        Range("D16:E25").ClearContents
        Target.Value = newVal
        a = ActiveCell

        Application.EnableEvents = True
    End If
End If

If a.Column = 4 Then
    Range("B5") = Range(a).Offset(0, -2).Value
        Else: Range("B5") = Range(a).Offset(0, -3).Value
End If

End Sub

Answer 1

将a 设置为Range object 可能有点矫枉过正，因为您已经通过查看单个单元格目标获得了行。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D16:E25")) Is Nothing Then
        On Error GoTo bm_Safe_Exit
        Application.EnableEvents = False
        If Intersect(Target, Range("D16:E25")).Cells.Count > 1 Then
            Application.Undo
            MsgBox "Please edit one cell at a time!"
        Else
            Dim newVal As Variant

            newVal = Target.Value
            Range("D16:E25").ClearContents
            Target.Value = newVal
            Cells(5, 2) = Cells(Target.Row, 2).Value

        End If
    End If

bm_Safe_Exit:
    Application.EnableEvents = True
End Sub

Answer 2

这里有3个问题： 首先，如果将 a 设置为 Range，那么正确的做法是

Set a = ActiveCell

其次，如果 a 设置为 Range，则在第二个 if 函数中调用它的正确方法是

If a.Column = 4 Then
    Range("B5") = a.Offset(0, -2).Value
       Else: Range("B5") = a.Offset(0, -3).Value
End If

而不是

If a.Column = 4 Then
    Range("B5") = Range(a).Offset(0, -2).Value
       Else: Range("B5") = Range(a).Offset(0, -3).Value
End If

第三个 if 函数应该放在中间

Set a = ActiveCell

和

Application.EnableEvents = True

那么当相交为真时，您的程序将按预期运行。