分离数据并放入单个工作表 Excel VBA [关闭]

Question

我有一个大型数据集，其中包含以下形式的 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

这些数据都包含在一个工作表中。我希望 excel 根据名称分隔数据，然后将每个时间序列放在同一工作簿中的单独工作表中。 VBA 可以做到这一点吗？

Answer 1

如果您想录制宏以查看发生了什么，请按照以下步骤操作：

1. 打开宏记录器
2. 按名称对数据进行排序
3. 从名字复制数据
4. 将其粘贴到另一张纸上（如果需要，请添加另一张纸）
5. 为工作表命名
6. 下一个名字重复

我还编写了一些代码供您开始使用。为此，您需要将数据选项卡命名为“MasterList”。代码按名称对 MasterList 上的行进行排序，然后为列表中的每个唯一名称创建一个新工作表并将适当的数据复制到新工作表，重复该过程直到所有名称都复制到新工作表。

将此代码添加到模块并运行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

Answer 2

我尝试了这段代码，它对我有用。

这将拆分数据（基于唯一名称）并将其粘贴到一个单独的工作表中，该工作表的名称将与 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

我在这段代码中所做的是：

1. 删除除具有初始数据表的工作表之外的所有工作表
2. 向下处理“名称”列并创建一个“标记”数组，指示每个数据拆分的位置
3. 创建一个新工作表并根据数组中的值将数据复制到其中