分离数据并放置在单独的工作表中Excel VBA [英] Separating data and placing in individual worksheets Excel VBA

问题描述

我有一个大数据集，超过80K的条目如下：

I have a large data set with over 80K entries of the following form:

        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？

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?

推荐答案

如果要记录一个宏，看看会发生什么，请按照下列步骤操作：

If you want to record a macro to see what happens, follow these steps:

1. 打开宏记录器


2. 按名称排序数据


3. 复制名称中的数据


4. 将其粘贴到另一张纸上（如果需要另外一张纸，则添加一张纸）


5. 将纸张命名为


6. 重复下一个名字

1. Turn on the macro recorder
2. Sort your data by name
3. Copy the data from the first name
4. Paste it onto another sheet (add a sheet if you need another)
5. Name the sheet
6. Repeat for the next name

我还写了一些可以用来开始的代码。为了使其工作，您需要命名数据选项卡MasterList。代码通过名称对MasterList上的行进行排序，然后对于列表中的每个唯一名称，创建一个新工作表，并将相应的数据复制到新工作表，重复该过程，直到所有名称都复制到新工作表。

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.

将此代码添加到模块并运行 DispatchTimeSeriesToSheets 程序。

Add this code to a module and run the DispatchTimeSeriesToSheets procedure.

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

这篇关于分离数据并放置在单独的工作表中Excel VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！