View Full Version : Copy rows to new tabs based on value in 1st column

07-18-2012, 07:25 AM
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

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

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

'ActiveCell.Offset(counter, 0).Select


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

Exit Sub
MsgBox "There has been an error, please check data and retry macro", vbExclamation

End Sub


attached is some sample data

08-03-2012, 04:48 AM
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.

Sub cellCheck2()
Dim rTestDate As Range
Dim rLastRow As Range

Set rLastRow = SetLastRow
Set rTestDate = rLastRow
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