分离数据并放置在单个工作表中 Excel VBA
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/11914163/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Separating data and placing in individual worksheets Excel VBA
提问by Mary
I have a large data set with over 80K entries of the following form:
我有一个包含以下形式的超过 80K 条目的大型数据集：
Name Date Value
1T17_4H19_3T19_3T21_2_a_2 09-Aug-11 -9.3159
1T17_4H19_3T19_3T21_2_a_2 10-Aug-11 -6.9662
1T17_4H19_3T19_3T21_2_a_2 11-Aug-11 -3.4886
1T17_4H19_3T19_3T21_2_a_2 12-Aug-11 -1.2357
1T17_4H19_3T19_3T21_2_a_2 15-Aug-11 0.1172
5 25_4Q27_4T30_4H34_3_3_3 19-Jun-12 -2.0805
5 25_4Q27_4T30_4H34_3_3_3 20-Jun-12 -1.9802
5 25_4Q27_4T30_4H34_3_3_3 21-Jun-12 -2.8344
5 25_4Q27_4T30_4Q32_a_a_a 25-Sep-07 -0.5779
5 25_4Q27_4T30_4Q32_a_a_a 26-Sep-07 -0.8214
5 25_4Q27_4T30_4Q32_a_a_a 27-Sep-07 -1.4061
This data is all contained in a single worksheet. I wish excel to separate the data according to name then place each time series in a separate worksheet in the same workbook. Is this possible with VBA?
这些数据都包含在一个工作表中。我希望 excel 根据名称分离数据，然后将每个时间序列放在同一个工作簿中的单独工作表中。这可以用 VBA 实现吗？
采纳答案by Jon Crowell
If you want to record a macro to see what happens, follow these steps:
如果要录制宏以查看会发生什么，请按照下列步骤操作：
- Turn on the macro recorder
- Sort your data by name
- Copy the data from the first name
- Paste it onto another sheet (add a sheet if you need another)
- Name the sheet
- Repeat for the next name
- 打开宏记录器
- 按名称对数据进行排序
- 从名字复制数据
- 将其粘贴到另一张纸上（如果需要，请添加一张纸）
- 命名工作表
- 重复下一个名字
I have also written some code that you can use to get started. In order for this to work, you need to name the data tab "MasterList". The code sorts the rows on MasterList by name, then for each unique name in the list, creates a new sheet and copies the appropriate data to the new sheet, repeating the process until all names have been copied to new sheets.
我还编写了一些代码，您可以使用它们开始。为了使其工作，您需要将数据选项卡命名为“MasterList”。代码按名称对 MasterList 上的行进行排序，然后为列表中的每个唯一名称创建一个新工作表并将适当的数据复制到新工作表中，重复该过程直到所有名称都已复制到新工作表中。
Add this code to a module and run the DispatchTimeSeriesToSheetsprocedure.
将此代码添加到模块并运行该DispatchTimeSeriesToSheets过程。
Sub DispatchTimeSeriesToSheets()
Dim ws As Worksheet
Set ws = Sheets("MasterList")
Dim LastRow As Long
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
SortMasterList LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortMasterList(LastRow As Long, ws As Worksheet)
ws.Range("A2:C" & LastRow).Sort Key1:=ws.Range("A1"), Key2:=ws.Range("B1")
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("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
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 tgt As Worksheet
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master List.", vbCritical, _
"Time Series Parser"
End
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
Set tgt = Sheets(name)
' copy header row from src to tgt
tgt.Range("A1:C1").Value = src.Range("A1:C1").Value
' copy data from src to tgt
tgt.Range("A2:C" & Last - Start + 2).Value = _
src.Range("A" & Start & ":C" & Last).Value
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
回答by Alex P
I tried this code out and it worked for me.
我试过这段代码，它对我有用。
This will split the data (based on unique name) and paste it into a separate worksheet that will be named the same as the name in column A.
这将拆分数据（基于唯一名称）并将其粘贴到一个单独的工作表中，该工作表将与 A 列中的名称相同。
Sub SplitData()
Dim DataMarkers(), Names As Range, name As Range, n As Long, i As Long
Set Names = Range("A2:A" & Range("A1").End(xlDown).Row)
n = 0
DeleteWorksheets
For Each name In Names
If name.Offset(1, 0) <> name Then
ReDim Preserve DataMarkers(n)
DataMarkers(n) = name.Row
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
n = n + 1
End If
Next name
For i = 0 To UBound(DataMarkers)
If i = 0 Then
Worksheets(1).Range("A2:C" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1")
Else
Worksheets(1).Range("A" & (DataMarkers(i - 1) + 1) & ":C" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1")
End If
Next i
End Sub
Sub DeleteWorksheets()
Dim ws As Worksheet, activeShtIndex As Long, i As Long
activeShtIndex = ActiveSheet.Index
Application.DisplayAlerts = False
For i = ThisWorkbook.Worksheets.Count To 1 Step -1
If i <> activeShtIndex Then
Worksheets(i).Delete
End If
Next i
Application.DisplayAlerts = True
End Sub
What I am doing in this code is:
我在这段代码中所做的是：
- Delete all worksheets apart from the one with the initial data table
- Work down the 'Name' column and create an array of 'markers' that indicate where each data split is
- Create a new worksheet and copy the data to it based on the values in the array
- 删除除带有初始数据表的工作表之外的所有工作表
- 处理“名称”列并创建一个“标记”数组，指示每个数据拆分的位置
- 创建一个新的工作表并根据数组中的值将数据复制到其中
