Question

我正在寻找关于如何查看按名称排序的列并为每个组输入左侧序列号的任何建议（即名称的第一个块= 1，名称的第2个块= 2等等）请看下面的例子：

    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行开始，我要输入的标识符在B列中，名称在C列中。下面显示的是该宏作为基础，但问题对任何建议都是开放的。

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

请注意，我不想将其分配到其他电子表格。宏只是我认为可以根据我遇到的情况修改的一个例子。

为列中的每组名称输入顺序标识符

0 个答案: