Solved: VBA to create a separate sheet for each month

[simora]

Trying to get VBA code to go through the data and create a separate sheet for each month and name it with the name of the month, but leave the original sheet in place.
Then, arrange the date in the correct date order on each page. 1 - 31
See attached sample worksheet.
I tried modifying this @ http://www.ozgrid.com/VBA/item-worksheets.htm but no go!

Thanks

[Tinbendr]

[VBA]
Public Sub Months()

Dim MyArray As Variant
Dim WS As Worksheet
Dim A As Long

For A = 1 To 12
ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WS = ActiveSheet
WS.Name = MonthName(A)
Worksheets("Rawdata").Rows("1:2").Copy WS.Range("a1")
Next
End Sub

Public Sub ParseDataByMonth()
Dim WS As Worksheet
Dim WSdest As Worksheet
Dim LastRow As Long
Dim LRDest As Long
Dim aCell As Range

Set WS = Worksheets("RawData")

With WS
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
End With
For Each aCell In WS.Range("D3" & LastRow)
Set WSdest = Worksheets(MonthName(Month(aCell.Value)))
With WSdest
LRDest = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
aCell.EntireRow.Copy WSdest.Range("A" & LRDest)
End With
Next

For A = 1 To 12
SortMonth ActiveWorkbook.Worksheets(MonthName(Month(A)))
Next

End Sub

Sub SortMonth(WS As Worksheet)

Application.DisplayAlerts = False
Dim LastRow
With WS
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row

WS.Sort.SortFields.Clear
WS.Sort.SortFields.Add Key:=Range("D2" & LastRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
WS.Sort.SortFields.Add Key:=Range("E2:E" & LastRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With WS.Sort
.SetRange Range("A3:K" & LastRow)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.DisplayAlerts = True
End Sub
[/VBA]

[simora]

Thanks; However, the code gives an error in Excel 2003.
Compile Error:
Method or Data Member Not Found. This is where the error is highlighted in
Sub SortMonth(WS As Worksheet) WS.Sort.SortFields.Clear

[p45cal]

beat me to it.. however, developed in XL2003!:
[VBA]Sub blah()
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
Worksheets("TempRawData").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Sheets("RawData").Copy After:=Sheets(1)
Set TempRawData = ActiveSheet
TempRawData.Name = "TempRawData"
Set ulist = Sheets.Add
ulist.Name = "UniqueList"

With TempRawData
.Range("B1").Value = "Month"
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
With .Range("B3:B" & LR)
.NumberFormat = "General"
.FormulaR1C1 = "=TEXT(RC[2],""mm-yyyy"")"
.Calculate
.NumberFormat = "@"
.Value = .Value
End With
.Range("B1:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ulist.Range("A1"), Unique:=True
With ulist
UListLR = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rRange = .Range("A3:A" & UListLR) 'A3 rather than A2 because there's a completely blank row at the top of the original data.
End With
For Each rCell In rRange.Cells
strText = rCell
.Range("A1").AutoFilter 2, strText
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(strText).Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a sheet named as content of rCell
Set NewSht = Worksheets.Add
NewSht.Name = strText
'Copy the visible filtered range (default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=NewSht.Range("A1")
NewSht.Columns(2).Clear
'Application.Goto NewSht.UsedRange
NewSht.UsedRange.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
NewSht.Cells.Columns.AutoFit
Set NewSht = Nothing
Next rCell
Application.DisplayAlerts = False
.Delete
ulist.Delete
Application.DisplayAlerts = True
End With
End Sub
[/VBA]

[simora]

p45cal:

THANKS ¡
Your code Works, but a few questions.
Why does it start creating the new sheets @ 02-2009 rather than 01-2009 .
Also it continues and then 01-2009 comes after 11-2009 , so its 11-2009 - 1-2009 - 12-2009 as the last 3 sheets.
I’m trying to understand the coding.
Also, how do I preserve the formatting from the original RawData page ?

Really appreciate it. Thanks.

[p45cal]

p45cal:

THANKS ¡
Your code Works, but a few questions.
Why does it start creating the new sheets @ 02-2009 rather than 01-2009 .
Also it continues and then 01-2009 comes after 11-2009 , so its 11-2009 - 1-2009 - 12-2009 as the last 3 sheets.
I’m trying to understand the coding.

It's the order in which the months first appear in the original list.
I've added sorting the temporary raw data sheet in the code below:
[VBA]Sub blah()
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
Worksheets("TempRawData").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Sheets("RawData").Copy After:=Sheets(1)
Set TempRawData = ActiveSheet
TempRawData.Name = "TempRawData"

Set ulist = Sheets.Add
ulist.Name = "UniqueList"

With TempRawData
.Range("B1").Value = "Month"
.UsedRange.Sort Key1:=.Range("D2"), Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
With .Range("B2:B" & LR) 'note this change
.NumberFormat = "General"
.FormulaR1C1 = "=TEXT(RC[2],""mm-yyyy"")"
.Calculate
.NumberFormat = "@"
.Value = .Value
End With
.Range("B1:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ulist.Range("A1"), Unique:=True
With ulist
UListLR = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rRange = .Range("A2:A" & UListLR) 'A2 because that blank row has disappeared after sorting.
End With
For Each rCell In rRange.Cells
strText = rCell
.Range("A1").AutoFilter 2, strText
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(strText).Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a sheet named as content of rCell
Set NewSht = Worksheets.Add
NewSht.Name = strText
'Copy the visible filtered range (default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=NewSht.Range("A1")
NewSht.Columns(2).Clear
'Application.Goto NewSht.UsedRange
NewSht.UsedRange.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
NewSht.Cells.Columns.AutoFit
Set NewSht = Nothing
Next rCell
Application.DisplayAlerts = False
.Delete
ulist.Delete
Application.DisplayAlerts = True
End With
End Sub
[/VBA]

Also, how do I preserve the formatting from the original RawData page ?

The formatting seems to be kept here; what formatting do you mean?

[simora]

Great:
It works.
RE: The formatting seems to be kept here; what formatting do you mean?
I was thinking of the column widths, fonts, etc.. Like copying The heading row of RawData and replicating across the pages.
Maybe modifying this area ? NewSht.Cells.Columns.AutoFit.
I'm looking @ the code.
Again. Thanks.

[p45cal]

With the code in msg#6 the headers and fonts are copied, only the columnwidths are not. I've made a few modifications:
[vba]Sub blah()
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
Worksheets("TempRawData").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Sheets("RawData").Copy After:=Sheets(1)
Set TempRawData = ActiveSheet
TempRawData.Name = "TempRawData"

Set ulist = Sheets.Add
ulist.Name = "UniqueList"

With TempRawData
.Range("B1").Value = "Month"
.UsedRange.Sort Key1:=.Range("D2"), Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
With .Range("B2:B" & LR)
.NumberFormat = "General"
.FormulaR1C1 = "=TEXT(RC[2],""mm-yyyy"")"
.Calculate
.NumberFormat = "@"
.Value = .Value
End With
.Range("B1:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ulist.Range("A1"), Unique:=True
With ulist
UListLR = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rRange = .Range("A2:A" & UListLR) 'A2 because that blank row has disappeared after sorting.
End With
For Each rCell In rRange.Cells
strText = rCell
.Range("A1").AutoFilter 2, strText
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(strText).Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a sheet named as content of rCell
Set NewSht = Worksheets.Add
NewSht.Name = strText
'Copy the visible filtered range (default of Copy Method) and leave hidden rows
.Range("_FilterDatabase").Copy
NewSht.Range("A1").PasteSpecial xlPasteColumnWidths
NewSht.Range("A1").PasteSpecial xlPasteAll
'.UsedRange.Copy Destination:=NewSht.Range("A1")'delete or comment out
NewSht.Columns(2).Clear
NewSht.UsedRange.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'NewSht.Cells.Columns.AutoFit'delete or comment out
NewSht.Range("A1").Select
Set NewSht = Nothing
Next rCell
Application.DisplayAlerts = False
.Delete
ulist.Delete
Application.DisplayAlerts = True
End With
End Sub
[/vba]

[simora]

p45cal:

I saw how the changes work. Exactly what I was looking into but didn't get the details perfect as you did.

THANKS !