input列中每组名称的顺序标识符

我正在寻找任何build议，我怎样才能查看通过按名称sorting的列，并为每个组input一个连续的编号（即第一块名称= 1，第二块名称= 2等on）请看下面的例子：

1 ALAMEDA 1 ALAMEDA 1 ALAMEDA 1 ALAMEDA 1 ALAMEDA 1 ALAMEDA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 2 CONTRA COSTA 3 LOS ANGELES 3 LOS ANGELES 3 LOS ANGELES 3 LOS ANGELES 3 LOS ANGELES 3 LOS ANGELES 3 LOS ANGELES 3 LOS ANGELES 

这只是一个更大的列表样本。 我有一个现有的代码，我已经能够从这个论坛修改，将列中的每个名称组作为一个系列，并粘贴到一个新的工作表上每个名称的所有数据。 我被阻止在哪里修改它做这个练习的可能性。
数据从第2行开始，我要input的标识符在列B中，名称在列C中。下面显示的是该macros作为基础，但问题是对任何build议都开放的。

 Sub AllocatedataCSVwkb() Dim ws As Worksheet Set ws = Sheets("CSV Master") Dim lastRow As Long lastRow = Range("C" & ws.Rows.Count).End(xlUp).Row ' stop processing if we don't have any data If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False CopyDataToSheets lastRow, ws ws.Select Application.ScreenUpdating = True End Sub Sub CopyDataToSheets(lastRow As Long, src As Worksheet) Dim rng As Range Dim cell As Range Dim Series As String Dim SeriesStart As Long Dim SeriesLast As Long Set rng = Range("C1:C" & lastRow) SeriesStart = 1 Series = Range("C" & SeriesStart) For Each cell In rng If cell.Value <> Series Then SeriesLast = cell.Row - 1 CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series Series = cell.Value SeriesStart = cell.Row End If Next ' copy the last series SeriesLast = lastRow CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series End Sub Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _ name As String) Dim wb As Workbook: Set wb = Workbooks.Add Dim tgt As Worksheet Set tgt = wb.Sheets(1) tgt.name = name ' copy data from src to tgt src.Range("A" & Start & ":O" & Last).Copy tgt.Range("A1").PasteSpecial xlPasteAll wb.SaveAs name.xls, FileFormat:=xlCSV, CreateBackup:=False wb.Close (True) End Sub Function SheetExists(name As String) As Boolean Dim ws As Worksheet SheetExists = True On Error Resume Next Set ws = Sheets(name) If ws Is Nothing Then SheetExists = False End If End Function 

请注意，我不想将它分配到不同的电子表格。 macros只是我认为可以修改我遇到的情况的一个例子。