Change text in one column based on count from another column

[ndimen]

Hello All,

I am new to this forum and just starting to increase my knowledge of coding. I don't know if there is another thread on this, I have not been able to find one.

Here is my dilemma: I am trying to create either a formula, macro or get the vba to count the text in column A based on a specific value in column F then change the text in column A to whatever have the highest count.

For example:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Store[/TD]
[TD]Channel[/TD]
[TD]EMP Hex[/TD]
[TD]Emp First Name[/TD]
[TD]Emp Last Name[/TD]
[TD]Emp Dec[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]AAA[/TD]
[TD]B[/TD]
[TD]1234EFGH[/TD]
[TD]JOHN[/TD]
[TD]SMITH[/TD]
[TD]12345678[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]BBB[/TD]
[TD]B[/TD]
[TD]1234EFGH[/TD]
[TD]JOHN[/TD]
[TD]SMITH[/TD]
[TD]12345678[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]BBB[/TD]
[TD]B[/TD]
[TD]1234EFGH[/TD]
[TD]JOHN[/TD]
[TD]SMITH[/TD]
[TD]12345678[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]BBB[/TD]
[TD]B[/TD]
[TD]1234EFGH[/TD]
[TD]JOHN[/TD]
[TD]SMITH[/TD]
[TD]12345678[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]BBB[/TD]
[TD]B[/TD]
[TD]1234EFGH[/TD]
[TD]JOHN[/TD]
[TD]SMITH[/TD]
[TD]12345678[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]BBB[/TD]
[TD]B[/TD]
[TD]1234EFGH[/TD]
[TD]JOHN[/TD]
[TD]SMITH[/TD]
[TD]12345678[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]BBB[/TD]
[TD]B[/TD]
[TD]1234EFGH[/TD]
[TD]JOHN[/TD]
[TD]SMITH[/TD]
[TD]12345678[/TD]
[/TR]
</tbody>[/TABLE]

I need something that will recognize, based on column F all being the same value, that cell A2 needs to change to BBB without changing the location.

I have a spreadsheet of about 5K+ rows.

I have already been able to use vba I found to remove dulicates, it associates the count based on column f but keeps it under the first entry in column A.

Any help or insights would be AMAZING!

Thanks in advance

 

[Kamolga]

This macro copy the sheet, take the duplicates out, add a count, define the max value of Emp Dec and finally replace in column A before deleting the calculation sheet. The proper method would have done it on Array instead of a sheet. Work with a copy, there is no undo, and maybe delete the end of macro to try it first (until it replace the lines, you will see what value it would use for replacement)
Note 1: the macro needs to be launched from that sheet.
Note 2: if same amount of AAA and BBB for a specific Emp Dec, it will use the first to appear for replacement

Sub MacroTest()
[COLOR=#008000]'Copy initial sheet[/COLOR]
Dim iSh As Worksheet: Set iSh = ActiveSheet
    iSh.Copy After:=iSh
[COLOR=#008000]'Rework new sheet[/COLOR]
Dim nSh As Worksheet: Set nSh = ActiveSheet
    [COLOR=#008000]'Only keep column A and F in new sheet[/COLOR]
    nSh.Columns("B:E").Delete Shift:=xlToLeft
  [COLOR=#008000]  'Define last row in new sheet[/COLOR]
    Dim lr As Long: lr = nSh.Cells(nSh.Rows.Count, "A").End(xlUp).Row
  [COLOR=#008000]  'Remove duplicate values[/COLOR]
    nSh.Range("A1:B" & lr).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
[COLOR=#008000]    'Reset last row in new sheet[/COLOR]
    lr = nSh.Cells(nSh.Rows.Count, "A").End(xlUp).Row
[COLOR=#008000]'Count the amount of unique Emp Dec with each unique store (in column C of new sheet)[/COLOR]
Dim i As Long
For i = 2 To lr
 nSh.Range("C" & i).Value = WorksheetFunction.CountIfs(iSh.Range("F:F"), nSh.Range("B" & i), iSh.Range("A:A"), nSh.Range("A" & i))
Next i
[COLOR=#008000]'Check max value by Emp Dec[/COLOR]
For i = 2 To lr
 nSh.Range("D" & i).Value = WorksheetFunction.MaxIfs(nSh.Range("C2:C" & lr), nSh.Range("B2:B" & lr), nSh.Range("B" & i))
Next i
[COLOR=#008000]'Delete the rows that are not max[/COLOR]
For i = 2 To lr
 If nSh.Range("C" & i).Value <> nSh.Range("D" & i).Value Then
    Rows(i).Delete
 End If
Next i
[COLOR=#008000]'Reset last row in new sheet[/COLOR]
    lr = nSh.Cells(nSh.Rows.Count, "A").End(xlUp).Row
[COLOR=#008000]'define last row in initial sheet[/COLOR]
Dim ilr As Long: ilr = iSh.Cells(iSh.Rows.Count, "A").End(xlUp).Row
[COLOR=#008000]'Replace Values[/COLOR]
For i = 2 To ilr
 iSh.Range("A" & i).Value = nSh.Range("A2:B" & lr).Find(iSh.Range("F" & i)).Offset(0, -1).Value
Next I
[COLOR=#008000]'Delete new sheet[/COLOR]
nSh.Delete
End Sub

 

[ndimen]

nSh.Range("D" & i).Value = WorksheetFunction.MaxIfs(nSh.Range("C2:C" & lr), nSh.Range("B2:B" & lr), nSh.Range("B" & i))

[/CODE]

Thank you, when I am getting an error right here.

 

[DanteAmor]

Try this

The process requires columns I, J, K to perform the calculations.
With 10 thousand it took 2 minutes

Option Explicit
Sub Change_Text()
    Dim b As Range, c As Range, r As Range, lr1 As Double, lr2 As Double
    
    Application.ScreenUpdating = False
    
    Range("A:A,F:F").Copy Range("I1")
    lr1 = Range("I" & Rows.Count).End(xlUp).Row
    Range("I1:J" & lr1).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    lr2 = Range("I" & Rows.Count).End(xlUp).Row
    Range("K2:K" & lr2).Formula = "=COUNTIFS($A$2:$A$" & lr1 & ",I2,$F$2:$F$" & lr1 & ",J2)"
    Range("I1:K" & lr2).Sort key1:=Range("J1"), order1:=xlAscending, key2:=Range("k1"), order2:=xlDescending, Header:=xlYes


    Set r = Range("J1:J" & lr2)
    For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
        Set b = r.Find(c.Offset(0, 5).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not b Is Nothing Then
            c.Value = b.Offset(0, -1).Value
        End If
    Next
    Range("I:K").ClearContents
    MsgBox "Done"
End Sub