セル範囲を1つの値で置き換える場合は、範囲内で値が複数回表示される

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の場合）、私はB1をJonに置き換えたいと思います。他のすべてのセルをクリアします。名前が複数回出現しない場合は、すべての値を同じままにします。ここで

Answer 1

は、辞書を使用しての方法です（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 

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