Separating data and placing in individual worksheets Excel VBA

Question

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

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?

Solution 1

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

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

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.

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

Solution 2

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.

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:

1. Delete all worksheets apart from the one with the initial data table
2. Work down the 'Name' column and create an array of 'markers' that indicate where each data split is
3. Create a new worksheet and copy the data to it based on the values in the array

Comments

[Jon Crowell]

It's fairly easy with VBA. The first thing you should do is to record a macro and manually move the data where you want it to go. You can modify the recorded macro to suit your needs.

[Alex P]

To be clear, you want to take this data in a single sheet and place it in separate worksheets based on name. Correct?

[Doug Glancy]

Maybe just download ASAP utilities? I've got my own code to do this, but this tool looks quite usable: asap-utilities.com/blog/index.php/2010/02/11/…

[Doug Glancy]

I forgot that's a paid-for utility, although you can get a 90-day trial. Here's a link to a sample workbook that does what you want: blog.contextures.com/archives/2012/02/21/…

[Mary]

Remnant- Yes this is exactly correct. Head of Catering- As I am sorting by name I am unsure how to do this by VBA, even by recording a macro as the data is all adjacent. Thanks for the links Doug! Unfortunately I am on a mac and its a windows only program.... otherwise it looks ideal!

[Mary]

works great! Thank you! Exactly what I needed. Appreciate the help.

[Mary]

This also works really well. Thank you. The problem with recording a macro was that the series are different lengths so part (3) would have caused problems? But your code is really efficient. Thank you!

[Jon Crowell]

@Mary, the macro recorder is definitely just a starting point. Your problem was a fun one to solve -- glad it's working for you.

[Mary]

Hi Head of Catering and @Remnant. Is it possible to use this code to separate the data in exactly the same way except according to the second (or third) element in the name (e.g. 4H19 in 1T17_4H19_3T19_3T21_2_a_2?). So in each sheet created I would have a column for each name that contains that second element (where that column would contain the time series as before). It's wonderful what you guys can do with a bit of code!

[Jon Crowell]

You can. Look up the Mid function and use it on the name. Here's a good link: techrepublic.com/article/…