如果单元格值等于范围内的任何单元格值，则复制相邻单元格

Question

我正在处理从 G:N 的一系列列，以注册客户姓名和与姓名相邻的电话号码，如下图所示

客户名称可能在范围内重复多次，我需要做的是使用 vba 代码将客户的电话号码复制到下一个相邻单元格（如果该名称之前在四个中的任何一个重复）名称列（“G-I-K-M”）.....

不幸的是，我无法使用 xlookup 或其他公式解决它，因为如果范围内没有匹配项，那么我必须手动插入电话号码，这会覆盖单元格中的公式并阻止其在新行中展开每次我都必须将公式复制到新单元格

请寻求您的专业帮助。

Answer 1

• 右键单击工作表选项卡，选择

  View Code

  并将代码粘贴到代码窗口中

微软文档：

应用程序.相交方法（Excel）

应用程序.Union方法（Excel）

工作表.更改事件（Excel）

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Const START_ROW = 5
    Const COL_NAME_FIRST = 7 ' Col G
    Const CNT_NAME = 4
    With Target
        If .CountLarge > 1 Or .Row < START_ROW Or Len(.Cells(1).Value) = 0 Then Exit Sub
        Dim rngName As Range, i As Long, rngCol As Range
        Set rngName = Me.Columns(COL_NAME_FIRST)
        For i = 1 To CNT_NAME - 1
            Set rngName = Union(rngName, Me.Columns(COL_NAME_FIRST).Offset(, i * 2))
        Next
        If Application.Intersect(Target, rngName) Is Nothing Then Exit Sub
        Set rngName = Intersect(rngName, Me.UsedRange)
        For Each rngCol In rngName.Columns
            If rngCol.Column <> .Column Then
                Dim vRes: vRes = Application.Match(.Value, rngCol, 0)
                If Not IsError(vRes) Then
                    Application.EnableEvents = False
                    .Offset(, 1) = rngCol.Offset(, 1).Cells(vRes)
                    Application.EnableEvents = True
                    Exit Sub
                End If
            End If
        Next
    End With
End Sub