mrrcx1
07-18-2012, 07:25 AM
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
:banghead:
attached is some sample data
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
:banghead:
attached is some sample data