Sub SplitData()
Const clngDateCol As Long = 2
Const clngTimeCol As Long = 3
Dim rngLastCell As Range
Dim lngRow As Long
Dim lngRowBgn As Long
Dim datPrevDate As Date
Dim strPrevTime As String
Dim wksNew As Worksheet
'
With ActiveSheet
lngRowBgn = 1
datPrevDate = .Cells(lngRowBgn, clngDateCol).Value
strPrevTime = .Cells(lngRowBgn, clngTimeCol).Text
Set rngLastCell = LastUsedCell(ActiveSheet)
For lngRow = 2 To rngLastCell.Row + 1
If ((.Cells(lngRow, clngDateCol).Value <> datPrevDate) Or (.Cells(lngRow, clngTimeCol).Text <> strPrevTime)) Then
Set wksNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wksNew.Name = SheetNameFromDate(datPrevDate)
.Range(.Cells(lngRowBgn, 1), .Cells(lngRow - 1, rngLastCell.Column)).Copy _
Destination:=wksNew.Cells(1, 1)
lngRowBgn = lngRow
datPrevDate = .Cells(lngRowBgn, clngDateCol).Value
strPrevTime = .Cells(lngRowBgn, clngTimeCol).Text
End If
Next
.Activate
End With
Housekeeping:
Set rngLastCell = Nothing
Set wksNew = Nothing
Exit Sub
Err_Exit:
Err.Clear
Resume Housekeeping
End Sub
' Create a worksheet name from a date.
Function SheetNameFromDate(ByVal datToUse As Date) As String
Dim intCntr As Integer
Dim strPrefix As String
strPrefix = Format(datToUse, "yymmdd-")
intCntr = 1
Do While WorksheetExists(strPrefix & Format(intCntr))
intCntr = intCntr + 1
Loop
SheetNameFromDate = strPrefix & Format(intCntr)
End Function
' Check if a particular sheet exists within ThisWorkbook.
Function WorksheetExists(ByVal strWks As String) As Boolean
WorksheetExists = False
On Error GoTo Err_Exit
WorksheetExists = (ThisWorkbook.Worksheets(strWks).Name <> vbNullString)
Housekeeping:
Exit Function
Err_Exit:
Err.Clear
Resume Housekeeping
End Function
'Find the last used cell in a worksheet.
Function LastUsedCell(wksToUse As Worksheet) As Range
Dim lngRow As Long
Dim lngCol As Long
Dim rngFound As Range
'
Set LastUsedCell = wksToUse.Cells(1, 1)
On Error GoTo Err_Exit
'
Set rngFound = wksToUse.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If (Not (rngFound Is Nothing)) Then
lngRow = rngFound.Row
Set rngFound = wksToUse.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
lngCol = rngFound.Column
Set LastUsedCell = wksToUse.Cells(lngRow, lngCol)
End If
Housekeeping:
Set rngFound = Nothing
Exit Function
Err_Exit:
Err.Clear
Resume Housekeeping
End Function
