Добавить уникальный идентификатор в список номеров - VBA

У меня есть список номеров (50 000+), и мне нужно добавить идентификатор в конец каждой уникальной группы. Идентификатор имеет формат "-###".

151022
151022
151020
150922
150715
150911
151014
151021
151020
151019
151019
151019
151020

Мне нужно, чтобы это печаталось так

151022-001
151022-002
151020-001
150922-001
150715-001
150911-001
151014-001
151021-001
151020-002
151019-001
151019-002
151019-003
151020-002

В настоящее время у меня есть этот код, который я нашел и немного изменил. Если бы я мог заставить его начать подсчет уникальных значений с -002, я полагаю, что это решило бы эту проблему.

Option Explicit

Sub test()
    Dim uniqueCounter As New Scripting.Dictionary
    Dim counter As Long
    Dim rowCount As Long
    Dim identifer As String


    rowCount = ActiveCell.CurrentRegion.Rows.Count 'Whatever code you want to put in to calculate the last row

    For counter = 1 To rowCount
        identifer = Sheet1.Cells(counter, 1) 'Put whatever number of combination of cells which the row unique here (maybe it's just the one)
        If uniqueCounter.Exists(identifer) Then
            uniqueCounter(identifer) = CLng(uniqueCounter(CStr(Sheet1.Cells(counter, 1)))) + 1
            Sheet1.Cells(counter, 2) = identifer & "-00" & uniqueCounter(CStr(Sheet1.Cells(counter, 1)))
        Else
            uniqueCounter.Add identifer, "0"
            Sheet1.Cells(counter, 2) = identifer
        End If
    Next counter

End Sub

Это то, что он сейчас отображает:

151022  151022
151022  151022-001
151020  151020
150922  150922
150715  150715
150911  150911
151014  151014
151021  151021
151020  151020-001
151019  151019
151019  151019-001
151019  151019-002
151020  151020-002

Спасибо всем!


loops excel excel-formula vba
person Robo_Hobo    schedule 24.08.2016    source источник

Ответы (1)


arrow_upward
4
arrow_downward

Я знаю, что вы просили vba, но простая формула даст вам желаемый результат.

В B1 поставить:

=A1& "-" &TEXT(COUNTIF($A$1:A1,A1),"000")

И скопируйте объем данных.

введите здесь описание изображения

Если вы хотите это в vba; Я бы сделал что-то вроде этого:

Sub test2()
    Dim rng As Range
    Dim rngcnt As Range
    Dim firstrow As Long
    Dim lastrow As Long
    Dim columnNumber As Long
    Dim ws As Worksheet

    Set ws = Worksheets("Sheet15") 'change to your sheet
    firstrow = 1 'change to your first row of data
    columnNumber = 1 'change to the column number

    With ws
        lastrow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
        For i = firstrow To lastrow
            .Cells(i, columnNumber + 1) = .Cells(i, columnNumber) & "-" & Format(Application.WorksheetFunction.CountIf(.Range(.Cells(firstrow, columnNumber), .Cells(i, columnNumber)), .Cells(i, columnNumber)), "000")
        Next i
    End With

End Sub

Что эффективно делает то же самое, что и приведенная выше формула.

person Scott Craner    schedule 24.08.2016
comment
++ вам когда-нибудь понадобится писать VBA. :) - person cyboashu; 24.08.2016
comment
@cyboashu зачем изобретать велосипед? - person Scott Craner; 24.08.2016
comment
Круто, сработало идеально. Я попробовал аналогичную формулу, прежде чем перейти к VBA, но по какой-то причине она работала неправильно. Ваше здоровье! - person Robo_Hobo; 24.08.2016