Change value of a range of cells, when a row limit is met - excel

Question

The results I need is shown in this image.
Previous data, and results needed
I have 1 column of data with multiple repeating Values, and need to CHANGE these Values if they repeat more times than a limit I set.
For example, there are "Andre" 3 times in the column, "Bruno" 2 times in the column, and "Charlie" 7 times in the column. The repeat limit is 2. The result I need would be:
Andre 1
Andre 1
Andre 2
Bruno
Bruno
Charlie 1
Charlie 1
Charlie 2
Charlie 2
Charlie 3
Charlie 3
Charlie 4
Bruno is left the same, as it does not EXCEED the limit I set, which is 2. Is this possible to do with VBA?
Note: very early first time learner of VBA.

Answer 1

Append Indexes in a Particular Way
Option Explicit
Sub AppendIndexes()
' Define constants.
' Source
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "B2"
Const sRowLimitCellAddress As String = "D7"
' Destination
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "B16"
Const dDelimiter As String = " "
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
' Attempt to store the row limit in a variable ('sRowLimit').
Dim sRowLimit As Long
On Error Resume Next
sRowLimit = sws.Range(sRowLimitCellAddress).Value
On Error GoTo 0
' Validate the row limit.
If sRowLimit < 1 Then
MsgBox "The row limit needs to be an integer greater than 0.", vbCritical
Exit Sub
End If
' Reference the first source cell ('sfCell').
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim srg As Range
' Reference the source (one-column) range ('srg').
With sfCell.CurrentRegion.Columns(sfCell.Column)
Set srg = sfCell.Resize(.Row + .Rows.Count - sfCell.Row)
End With
' Note that there are many different ways to do it.
' To see if it is the correct range you can use e.g.:
'Debug.Print srg.Address(0, 0)
' or:
'MsgBox srg.Address(0, 0)
' Store the number of rows of the source range in a variable ('rCount').
Dim rCount As Long: rCount = srg.Rows.Count
Dim Data() As Variant
' Store the values from the source range
' in a 2D one-based one-column array, the data array ('Data').
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
Else
Data = srg.Value
End If
' Define a new dictionary (dict).
' Its 'keys' will hold the unique strings from the source range.
' Its 'items' will hold the rows in the unique counts array.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'A = a'
' Define the unique counts array ('uCounts'), a 1D one-based array
' with the same number of rows as the number of rows in the data array,
' to hold the count of each unique string.
Dim uCounts() As Long: ReDim uCounts(1 To rCount)
' The size of the array is probably too big but the 'mrCount' variable
' will determine the number of rows of interest, the mapping rows count.
Dim r As Long ' Current Data Array Row
Dim mr As Long ' Current Mapping Row
Dim mrCount As Long ' Current and Final Mapping Rows Count
Dim cString As String ' Current Data Array Value Converted to a String
' Loop through the rows of the data array...
For r = 1 To rCount
' Retrieve the current value from the data array converted to a string.
cString = CStr(Data(r, 1))
' Replace the value with the string.
Data(r, 1) = cString
' Check if the string exists in the 'keys' of the dictionary.
If Not dict.Exists(cString) Then
mrCount = mrCount + 1 ' increment the mapping rows count...
dict(cString) = mrCount ' ... and write it to the associated 'item'
mr = mrCount ' retrieve the current mapping row
Else
mr = dict(cString) ' retrieve the current mapping row
End If
' In the current mapping row of the unique counts array,
' increment the number by 1.
uCounts(mr) = uCounts(mr) + 1
Next r
' Define the unique indexes array ('uIndexes'), a 1D one-based array
' with the same number of rows as the mapping rows count ('mrCount'),
' to hold the current index.
Dim uIndexes() As Long: ReDim uIndexes(1 To mrCount)
' Loop through the elements of the unique array and for each value
' greater than the row limit, write 1 to it.
For mr = 1 To mrCount
If uCounts(mr) > sRowLimit Then
uIndexes(mr) = 1
End If
Next mr
Erase uCounts
' Define the indexes counts array ('uIndexes'), a 1D one-based array
' with the same number of rows as the mapping rows count ('mrCount'),
' to hold the current indexes count, a number from 1 to the row limit.
Dim iCounts() As Long: ReDim iCounts(1 To mrCount)
Dim iCount As Long ' Current Index Count
Dim uIndex As Long ' Current Unique Index
' Write the resulting strings to the data array.
' Loop through the rows of the data array.
For r = 1 To rCount
' Retrieve the string from the current row of the data aray.
cString = Data(r, 1)
' Retrieve the mapping row for the current string.
mr = dict(cString)
' Retrieve the unique index for the current mapping row.
uIndex = uIndexes(mr)
If uIndex > 0 Then
' Increment the current index count by 1.
iCount = iCounts(mr) + 1
' Check if the current index count is greater than the row limit.
If iCount > sRowLimit Then ' it is greater
iCount = 1 ' reset the current index count
uIndex = uIndex + 1 ' increment the 'uIndex' by 1, and...
uIndexes(mr) = uIndex ' ... write it to the unique indexes array
'Else ' the current count is not greater than the row limit
End If
iCounts(mr) = iCount ' write the count to the indexes counts array
' Build and write the resulting string to the current row
' of the data array (overwriting the (previous) string).
Data(r, 1) = cString & dDelimiter & CStr(uIndex)
End If
Next r
Erase iCounts
Erase uIndexes
Set dict = Nothing
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Reference the first destination cell ('dfCell').
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = dfCell.Resize(rCount)
' Write the strings from the data array to the destination range.
drg.Value = Data
' Clear below.
drg.Resize(dws.Rows.Count - drg.Row - rCount + 1).Offset(rCount).Clear
' Inform.
MsgBox "Indexes appeded.", vbInformation
End Sub

Answer 2

If you must use VBA:
Sub NumberIfVariableRowLimit()
Dim I As Long 'Iterate
Dim SrcRG As Range 'Source Range
Dim SrcArray() 'Source Array
Dim DestArray() 'Destination array
Dim CellCnt As Long 'Count of cells in range
Dim ItemCnt As Long 'Count keeping track of item number for each name
Dim TempCnt As Long 'Count of occurances of this item in source array
Dim TempStr As String 'Most recently checked item
Dim RowLimit As Long 'Row limit
RowLimit = 3 'Source this data however you like.
'Range/Array Setup
Set SrcRG = ActiveSheet.Range("B1:B28") 'Source Range
CellCnt = SrcRG.Count 'Count cells in source range
SrcArray = SrcRG 'Store range values in array
ReDim DestArray(1 To CellCnt) 'Resize output array
TempStr = "%&%" 'Initial Value
For I = 1 To CellCnt 'Iterate through array
ItemCnt = CountIfArray(SrcArray, SrcArray(I, 1)) 'Get occurances of item in array
'change -or- notchange value, move to output array
If ItemCnt > RowLimit Then
If TempStr = SrcArray(I, 1) Then
TempCnt = TempCnt + 1
Else
TempCnt = RowLimit
End If
DestArray(I) = SrcArray(I, 1) & " " & Application.WorksheetFunction.RoundDown(TempCnt / RowLimit, 0)
Else
DestArray(I) = SrcArray(I, 1)
End If
TempStr = SrcArray(I, 1) 'Store item value for next iteration
Next I
Sheet1.Range("C1").Resize(CellCnt, 1).Value = Application.Transpose(DestArray()) 'output
End Sub
Function CountIfArray(ARR(), vItem) As Long
Dim X As Long
Dim Y As Long
CountIfArray = 0
For X = LBound(ARR, 1) To UBound(ARR, 1)
For Y = LBound(ARR, 2) To UBound(ARR, 2)
If ARR(X, Y) = vItem Then
CountIfArray = CountIfArray + 1
End If
Next Y
Next X
End Function
Example of output:
Example using variable rowlimit: