如果该值在该范围内出现多次，则用一个值替换一系列单元格

Question

Company Contact Contact Contact Contact Contact
Company 1   Jon James   Jon Jon Mark
Company 2   Mark    Eric    Jon Eric    
Company 3   Jon Mark    Eric        
Company 4   Jon             
Company 5   Mark    Eric    James   James   

我在A列（公司名称）中有一个唯一值列表。然后，我有水平的联系人列表。

我想查找单元格的范围（对于公司1，它将是B1：E1），如果名称出现不止一次（例如，对于公司1，Jon），我想用Jon替换B1并清除所有其他细胞。如果没有名称出现多次，我想让所有值保持不变。

Answer 1

这是一种使用字典的方法（要求您通过VBE中的工具＆gt;引用添加对Microsoft脚本运行时的引用。）

Sub test()

Dim wb As Workbook
Dim wsSource As Worksheet

Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet6")

Dim loopRange As Range
Dim currRow As Range

Set loopRange = wsSource.Range("B2:F6")

For Each currRow In loopRange.Rows

    If Application.WorksheetFunction.CountA(currRow) > 1 Then

        If FindFrequency(currRow)(1) > 1 Then

            With wsSource
                .Cells(currRow.Row, 2) = FindFrequency(currRow)(0)
                .Range(.Cells(currRow.Row, 3), .Cells(currRow.Row, 6)).ClearContents
            End With
        End If

    End If

Next currRow

End Sub

Function FindFrequency(currRow As Range) As Variant 'Adapted from here https://www.extendoffice.com/documents/excel/1581-excel-find-most-common-value.html#a2

Dim rng As Range
Dim dic As Object 'late binding
Dim xMax As Long
Dim xOutValue As String
Dim xValue As String
Dim xCount As Long

Set dic = CreateObject("scripting.dictionary")

On Error Resume Next

xMax = 0
xOutValue = ""

For Each rng In currRow.Columns

    xValue = rng.Text

    If xValue <> "" Then

        dic(xValue) = dic(xValue) + 1
        xCount = dic(xValue)

        If xCount > xMax Then
            xMax = xCount
            xOutValue = xValue
        End If

    End If

Next rng

FindFrequency = Array(xOutValue, xMax)

Set dic = Nothing

End Function

Answer 2

使用工作表函数CountIf，我们可以确定使用哪个联系人：

Option Explicit
Sub GetContactName()
Dim i As Long, j As Long, sht As Worksheet, lastrow As Long, tempvalue As String

Set sht = ThisWorkbook.ActiveSheet
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

For i = 2 To lastrow
    For j = 2 To 6
        If Application.WorksheetFunction.CountIf(Range(Cells(i, 2), Cells(i, 6)), Cells(i, j)) > 1 Then
            tempvalue = Cells(i, j)
            Range(Cells(i, 2), Cells(i, 6)).ClearContents
            Cells(i, 2) = tempvalue
        End If
    Next j
Next i

End Sub