Split column to separate sheets based on text value

[ziggyfo]

Hi

Could someone possibly assist me, I am trying to achieve the following.

1. The information below is raw data that is pasted in and it will look exactly like the below.
2. I want the code to look down column A and split each race into its own sheet, rename the sheet and then remove the spaces between the times
3. The data is not static and under each race their may be various amounts of entries.

eg, of how i want the information to look on each sheet is below.

Appreciate any assistance with this.

Cheers

 

[maabadi]

If your Data is in only Column A Try this:

Sub ColumntoSheet()
Dim i As Long, Lr As Long, F As Long, S As Long, Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = ActiveSheet
Lr = Sh1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To Lr
If Left(Sh1.Range("A" & i).Value, 4) = "Race" Then
If F <> 0 Then S = i
If F <> 0 And S <> 0 Then
Worksheets.Add after:=ActiveSheet
Set Sh2 = ActiveSheet
Sh1.Range("A" & F & ":A" & S - 1).SpecialCells(xlCellTypeConstants, 23).Copy Sh2.Range("A1")
Sh2.Name = Sh1.Range("A" & F).Value
End If

F = i
End If
Next i
Worksheets.Add after:=ActiveSheet
Set Sh2 = ActiveSheet
Sh1.Range("A" & F & ":A" & Lr).SpecialCells(xlCellTypeConstants, 23).Copy Sh2.Range("A1")
Sh2.Name = Sh1.Range("A" & F).Value

End Sub

 

[ziggyfo]

I tried the code and getting an error. When i debug the error is on the following line

Sh1.Range("A" & F & ":A" & Lr).SpecialCells(xlCellTypeConstants, 23).Copy Sh2.Range("A1")

It opens up sheet 2, but then the error kicks in and sheet 2 is left blank.

 

[maabadi]

This VBA search based Word "Race". Is your Race names is Different? if Yes, Are all of Other values is Number (or Time)?

 

[ziggyfo]

Apologies maabadi, i should have been clearer in my original post. I was using race as an example, the actual information would vary from day to day so it would be location based. It might be Scotland (followed by the rows below that) then it may be London (followed with the information below that). What i am looking to do is split each location to its own tab.

 

[maabadi]

AND Don't Answer the Second Question?

Are all of Other values is Number (or Time)?

And if not, Please give me more example.

 

[ziggyfo]

I think this will be the easiest, this is the actual information i am working with

You will see there are two locations, "central park" and "doncaster" so for each location i am looking for the following. If you look at Central park as an example, you will see in A2 it says 6.09 (2-1-5) "6.09" is actually the time but the format is pasted in this format from the site.

 

[maabadi]

Try this:

Sub ColumntoSheet()
Dim i As Long, Lr As Long, F As Long, S As Long, Sh1 As Worksheet
Dim Sh2 As Worksheet, Vr1 As Double, Vr2 As Double, Vr As Long
Set Sh1 = ActiveSheet
Lr = Sh1.Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
For i = 1 To Lr
If Sh1.Range("A" & i).Value <> "" Then
Vr = VarType(Sh1.Range("A" & i).Value)
If Vr <> 5 Then
Vr1 = Left(Sh1.Range("A" & i).Value, (Application.WorksheetFunction.Find(".", Range("A" & i).Value) - 1)) * 1
Vr2 = Left(Sh1.Range("A" & i).Value, (Application.WorksheetFunction.Find("(", Sh1.Range("A" & i).Value) - 1)) * 1
If Vr1 = 0 And Vr2 = 0 Then
If F <> 0 Then S = i
If F <> 0 And S <> 0 Then
Worksheets.Add after:=ActiveSheet
Set Sh2 = ActiveSheet
Sh1.Range("A" & F & ":A" & S - 1).SpecialCells(xlCellTypeConstants, 23).Copy Sh2.Range("A1")
Sh2.Name = Sh1.Range("A" & F).Value
End If

F = i
End If
Vr1 = 0
Vr2 = 0
End If
End If
Next i
Worksheets.Add after:=ActiveSheet
Set Sh2 = ActiveSheet
Sh1.Range("A" & F & ":A" & Lr).SpecialCells(xlCellTypeConstants, 23).Copy Sh2.Range("A1")
Sh2.Name = Sh1.Range("A" & F).Value

End Sub

 

[ziggyfo]

Try this:

Sub ColumntoSheet()
Dim i As Long, Lr As Long, F As Long, S As Long, Sh1 As Worksheet
Dim Sh2 As Worksheet, Vr1 As Double, Vr2 As Double, Vr As Long
Set Sh1 = ActiveSheet
Lr = Sh1.Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
For i = 1 To Lr
If Sh1.Range("A" & i).Value <> "" Then
Vr = VarType(Sh1.Range("A" & i).Value)
If Vr <> 5 Then
Vr1 = Left(Sh1.Range("A" & i).Value, (Application.WorksheetFunction.Find(".", Range("A" & i).Value) - 1)) * 1
Vr2 = Left(Sh1.Range("A" & i).Value, (Application.WorksheetFunction.Find("(", Sh1.Range("A" & i).Value) - 1)) * 1
If Vr1 = 0 And Vr2 = 0 Then
If F <> 0 Then S = i
If F <> 0 And S <> 0 Then
Worksheets.Add after:=ActiveSheet
Set Sh2 = ActiveSheet
Sh1.Range("A" & F & ":A" & S - 1).SpecialCells(xlCellTypeConstants, 23).Copy Sh2.Range("A1")
Sh2.Name = Sh1.Range("A" & F).Value
End If

F = i
End If
Vr1 = 0
Vr2 = 0
End If
End If
Next i
Worksheets.Add after:=ActiveSheet
Set Sh2 = ActiveSheet
Sh1.Range("A" & F & ":A" & Lr).SpecialCells(xlCellTypeConstants, 23).Copy Sh2.Range("A1")
Sh2.Name = Sh1.Range("A" & F).Value

End Sub

Excellent thank you so much maabadi, it works perfectly

 

[maabadi]

You're Welcome & Thanks for Feedback.