excel - Excel Macro to add a character to duplicate values after the value exceeds 15 instances

Question

Currently operating in excel 2010

I am in the process of building a macro to format various reports so that the excel sheets can be input into an auto-load tool. This macro adds a unique number identifier to each case and then breaks cases into multiple lines depending on the amount of services being performed. So initially cases will be numbered in column A as 1,2,3,4,ect. Then the cases are split into multiple rows based on the number of services and the number in column A is used to group the services. So if case one has 3 services, case two has 1 service, and case three has 5 services, column A would look like 1,1,1,2,3,3,3,3,3 descending.

The auto-load tool only builds 15 lines per case. So I need to add code that will search column A and if a duplicate value exceeds 15 instances, add an "a" to the first 15 instances, a "b" to the second 15 instances, a "c" to the third 15 instances, and so on.

example:

In column A desending: if identifier looks like 1,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4 Then macro would update column A to look like this: 1,2,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3b,3b,4

Thanks for your time

This is the code I have worked out so far:

Sub Scrub_File()      
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
    range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
       LastRow = range("K" & Rows.Count).End(xlUp).Row
        range("A2").AutoFill Destination:=range("A2:A" & LastRow),   Type:=xlFillSeries
Dim InxSplit As Long
  Dim SplitCell() As String
  Dim RowCrnt As Long
  With Worksheets("Sheet1")
    RowCrnt = 2         ' The first row containing data.
    Do While True
      If .Cells(RowCrnt, "AI").Value = "End" Then
        Exit Do
      End If
      SplitCell = Split(.Cells(RowCrnt, "AI").Value, ",")
      If UBound(SplitCell) > 0 Then
        .Cells(RowCrnt, "AI").Value = SplitCell(0)
        For InxSplit = 1 To UBound(SplitCell)
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "AI").Value = SplitCell(InxSplit)
        .range(.Cells(RowCrnt, "A"), .Cells(RowCrnt, "AH")).Value = .range(.Cells(RowCrnt - 1, "A"), .Cells(RowCrnt - 1, "AH")).Value
        .range(.Cells(RowCrnt, "AL"), .Cells(RowCrnt, "AX")).Value = .range(.Cells(RowCrnt - 1, "AL"), .Cells(RowCrnt - 1, "AX")).Value
        Next
        End If
      RowCrnt = RowCrnt + 1
    Loop
  End With
End Sub

标签： excelvbaexcel-formulaexcel-2010

Answer 1

For an Excel formula, you can use:

=IF(COUNTIF($A:$A,A3)>15,  A3&CHAR(96+INT( (COUNTIF($A$3:A3,A3)-1)/15+1)),A3)

where your ID codes are in column A and start at, for example A3.

For a VBA macro, to be run after you have populated your ID column:

Option Explicit
Sub markDups()
    Dim WB As Workbook, WS As Worksheet
    Dim rID As Range, C As Range, D As Range
    Dim lcntID As Long, lposCnt As Long

Set WB = ThisWorkbook
Set WS = WB.Worksheets("sheet1")
With WS
    Set rID = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'alter as needed
End With

For Each C In rID
    Set D = C.Offset(0, 1) 'remove offset to overwrite
    lcntID = WorksheetFunction.CountIf(rID, C.Value2)
    If lcntID > 15 Then
        Set D = C.Offset(0, 1) 'remove offset to overwrite
        lposCnt = WorksheetFunction.CountIf(Range(rID(1, 1), C), C)
        D = C.Value2 & Chr((lposCnt - 1) \ 15 + 97)
    Else
        D = C.Value2
    End If
Next C

End Sub