Copy rows to new tabs based on value in 1st column

[mrrcx1]

Hi,
i have a bunch of data all organized by date. upwards of 53000 lines. its about 7 days worth of data points (taken every 10 sec.)
What i am trying to do is have the macro look for a date change (all of the data is in order at this point) and cut or copy (whichever is easier) and paste it in a new tab. it would be nice as well to get the value in the 1st column to be the title of the new tab as well to save time.

here is my code so far, right now its color coding the different dates so i can tell it recognizes them:



Sub cellcheck()
Const myColumn As String = "A" '<--column whose cells to be compared
Dim RangeToCheck As Range
Dim oneCell As Range, oneCell2 As Range
Dim currentValue As Long '<--assumed that values are always of LONG type
Dim copydata As Long '<--holds date index
Dim base_data As Worksheet, new_sheet As Worksheet
Dim x As Integer

Set base_data = ActiveSheet
base_data.Name = "Base Data"
counter = -1
Set RangeToCheck = base_data.Columns("A"). _
SpecialCells(xlCellTypeConstants) '<-- will loop through every cell in the column that contains a value

For Each oneCell In RangeToCheck
If oneCell.Interior.ColorIndex = xlNone Then
currentValue = oneCell.Value

On Error GoTo Oops:
currentColorIndex = currentColorIndex + 1 '<-- might run out of colors if there are too many different Values
oneCell.Copy

'create new sheet if values are different
Set new_sheet = Sheets.Add
new_sheet.Activate
new_sheet.Name = currentValue

'If currentValue = oneCell.Value Then
' counter = counter + 1
'Else
' counter = 0
'End If

'ActiveCell.Offset(counter, 0).Select
ActiveSheet.Paste

'base_data.Activate
'ActiveCell.EntireRow.Copy

On Error GoTo 0
For Each oneCell2 In RangeToCheck
With oneCell2
If .Value = currentValue Then
.Interior.ColorIndex = currentColorIndex
base_data.Activate
ActiveCell.EntireRow.Copy
End If
End With
Next oneCell2
End If
Next oneCell

Exit Sub
Oops:
oneCell.Select
MsgBox "There has been an error, please check data and retry macro", vbExclamation

End Sub



attached is some sample data

[Teeroy]

Hi mrrcx1,

This works (tested excel 2003). You can put in your own error handling. The sheets are named by date in Australian / English format; if you want US date format just reorder the assembly of sSheetName.

[vba]Sub cellCheck2()
Dim rTestDate As Range
Dim rLastRow As Range

Set rLastRow = SetLastRow
Set rTestDate = rLastRow
Do
If rTestDate.Offset(-1, 0).Value <> rTestDate.Value Then
Call CutAndPaste(rTestDate, rLastRow)
Set rLastRow = SetLastRow
Set rTestDate = rLastRow
End If
If rTestDate.Row = 2 Then
Call CutAndPaste(rTestDate.Offset(-1, 0), rLastRow)
End If
Set rTestDate = rTestDate.Offset(-1, 0)
Loop Until rTestDate.Row = 1
End Sub

Function SetLastRow()
With Sheets("Base Data")
Set SetLastRow = .Range("A" & .Cells.Rows.Count).End(xlUp)
End With
End Function

Sub CutAndPaste(rFirstRow As Range, rLastRow As Range)
Dim newWS As Worksheet
Dim sSheetName As String

sSheetName = Day(rLastRow) & "-" & Month(rLastRow) & "-" & Year(rLastRow)
Set newWS = Sheets.Add
newWS.Name = sSheetName
Sheets("Base Data").Range(rFirstRow.Row & ":" & rLastRow.Row).Cut Destination:=newWS.Range("A1")
End Sub
[/vba]