Макрос Excel для добавления символа к дублирующимся значениям после того, как значение превышает 15 экземпляров - PullRequest
Новая
       18

Макрос Excel для добавления символа к дублирующимся значениям после того, как значение превышает 15 экземпляров

0 голосов
/ 25 сентября 2019

В настоящее время работает в Excel 2010

Я нахожусь в процессе создания макроса для форматирования различных отчетов, чтобы листы Excel можно было вводить в инструмент автоматической загрузки.Этот макрос добавляет уникальный идентификатор номера для каждого случая, а затем разбивает случаи на несколько строк в зависимости от объема выполняемых услуг.Таким образом, первоначально случаи будут пронумерованы в столбце A как 1,2,3,4 и т. Д.Затем дела делятся на несколько строк в зависимости от количества услуг, а число в столбце A используется для группировки услуг.Таким образом, если в первом случае есть 3 услуги, во втором случае - 1 услуга, а в третьем случае - 5 услуг, столбец A будет выглядеть по убыванию 1,1,1,2,3,3,3,3,3.

Инструмент автоматической загрузки создает только 15 строк для каждого случая.Поэтому мне нужно добавить код, который будет искать столбец A, и если дублирующее значение превышает 15 экземпляров, добавить «a» в первые 15 экземпляров, «b» во вторые 15 экземпляров, «c» в третьи 15 экземпляров, и так далее.

пример:

В столбце A в порядке убывания: если идентификатор выглядит как 1,2,3,3,3,3,3,3,3,3,3,3,3,3, 3,3,3,3,3,4 Тогда макрос обновит столбец A, чтобы он выглядел следующим образом: 1,2,3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3a, 3b, 3b, 4

Спасибо за ваше время

Это код, который я разработал до сих пор: 

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

1 Ответ

0 голосов
/ 26 сентября 2019

Для формулы Excel вы можете использовать: 

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

, где ваши идентификационные коды находятся в столбце A и начинаются, например, A3.

Для VBAмакрос, запускаемый после заполнения столбца идентификатора: 

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
...