Sub DateDataToWorksheet()
' Cell range used for looping
Dim rCell As Range
' Location for data
Dim rAnchorCell As Range
' Name of month: Jan, Feb, etc.
Dim sMonthName As String
' Range of cells containing data.
Dim rDateCells As Range
' The last row in the data.
Dim iLastRow As Long
' Number of rows offset when putting data into month-specific worksheet.
Dim iOffsetRow As Long
' Row for next data item location.
Dim iNextDataRow As Long
' Worksheet containing source data.
Dim wsSource As Worksheet
' Month-specific worksheet.
Dim wsTarget As Worksheet
' Boolean indicating whether to delete source data as it is transferred to
' month-specific worksheet.
Dim bDeleteSourceData As Boolean
' Specify worksheet containing source data. It is Sheet1 in this example.
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
' The cell containing the header for dates data.
Set rAnchorCell = wsSource.Range("A3")
' Indicate whether to delete source data after transfer to month-specific workbook.
bDeleteSourceData = False
' Last row containing source data.
iLastRow = wsSource.Cells(1).Offset(100000).End(xlUp).Row
' Range containing all dates in source data.
Set rDateCells = rAnchorCell.Offset(1).Resize(iLastRow - rAnchorCell.Row)
' Loop all source data rows
For Each rCell In rDateCells
' Will be used to identify the month-specific worksheet.
sMonthName = Format(rCell, "mmm")
' Check worksheet exists.
Set wsTarget = Nothing
On Error Resume Next
Set wsTarget = Worksheets(sMonthName)
On Error GoTo 0
' Create the sheet if it does not exist.
If wsTarget Is Nothing _
Then
' Add month-specific sheet
Sheets.Add.Name = sMonthName
Set wsTarget = Worksheets(sMonthName)
wsTarget.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
With wsTarget
' Add a name to the worksheet for the first cell in the range where data
' will go into the month-specific worksheet.
.Names.Add Name:="AnchorCell", RefersTo:="='" & wsTarget.Name & "'!" & "$A$3"
' Put data headers into the target worksheet
.Range("AnchorCell").Value = "Date"
.Range("AnchorCell").Offset(, 1).Value = "Data"
End With
End If
' Record data for month-specific worksheet.
With wsTarget
' The next available row into which to put data.
iNextDataRow = .Range("AnchorCell").Offset(100000).End(xlUp).Row + 1
' Offset from the header row for the next availble data row.
iOffsetRow = iNextDataRow - .Range("AnchorCell").Row
' Put source data into the month-specific worksheet.
.Range("AnchorCell").Offset(iOffsetRow).Value = rCell.Value
.Range("AnchorCell").Offset(iOffsetRow, 1).Value = rCell.Offset(, 1).Value
' Autofit the two data columns so dates and data are viewable.
.Range("AnchorCell").Offset(iOffsetRow).EntireColumn.AutoFit
.Range("AnchorCell").Offset(iOffsetRow, 1).EntireColumn.AutoFit
End With
' Clear source data after it is transferred to month-specific worksheet.
If bDeleteSourceData _
Then
rCell.Value = ""
rCell.Offset(, 1).Value = ""
End If
Next rCell
' Arrange month-specific worksheets chronologically: Jan, Feb, etc.
Call ArrangeMonthWorksheets
End Sub
Sub ArrangeMonthWorksheets()
Dim asMonths() As String
ReDim asMonths(12)
Dim iMonth As Long
Dim wsMonth As Worksheet
Dim sMonthName As String
asMonths(1) = "Jan"
asMonths(2) = "Feb"
asMonths(3) = "Mar"
asMonths(4) = "Apr"
asMonths(5) = "May"
asMonths(6) = "Jun"
asMonths(7) = "Jul"
asMonths(8) = "Aug"
asMonths(9) = "Sep"
asMonths(10) = "Oct"
asMonths(11) = "Nov"
asMonths(12) = "Dec"
For iMonth = 1 To UBound(asMonths)
sMonthName = asMonths(iMonth)
' Check worksheet exists.
Set wsMonth = Nothing
On Error Resume Next
Set wsMonth = Worksheets(sMonthName)
On Error GoTo 0
If Not wsMonth Is Nothing _
Then
wsMonth.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next iMonth
End Sub
