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?
If you want to record a macro to see what happens, follow these steps:
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