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

时间:2017-12-20 17:05:23

标签: vba list replace lookup

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并清除所有其他细胞。如果没有名称出现多次,我想让所有值保持不变。

2 个答案:

答案 0 :(得分:0)

这是一种使用字典的方法(要求您通过VBE中的工具>引用添加对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

答案 1 :(得分:0)

使用工作表函数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

enter image description here enter image description here