我正在寻找关于如何查看按名称排序的列并为每个组输入左侧序列号的任何建议(即名称的第一个块= 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
请注意,我不想将其分配到其他电子表格。宏只是我认为可以根据我遇到的情况修改的一个例子。