Data Sorting by String and Integer Values

[rigneys]

I wrote a code that allows me to sort a long worksheet of data that consists of lists of objects that contain other objects onto individual worksheets based on the main objects name. The code works well but I am trying to simplify it. It is dependent on me knowing exactly what the object name is and how many objects total there are and I will not always know that. The object name will always be text followed by a number increasing in value ex. vessel 1, vessel 2, vessel 3...... After each vessel # will be rows of other data that needs to be copied to a new worksheet until the next vessel row is reached. Here is an example of some of my data and code for more understanding. I'm trying to write a more generic version that loops through my data and copies the list under each numbered vessel and pastes it to a new worksheet without me having to write the exact name.
For example:
Dim V As String
Dim i As Integer
lastrow = (Cells(Rows.Count, "A").End(xlUp).Row)
ThisValue = Cells(i, "A").Value
V = "Vessel"
For i=1 To lastrow
If ThisValue = V & i Then .........

But I'm having no luck so far

Below is an example of my current code I'm trying to simplify:

Sub DataSortingByVessel()
Dim rng1 As Range, rng2 As Range, Rng3 As Range
Dim lastrow As Long
Dim i As Long


lastrow = (Cells(Rows.Count, "A").End(xlUp).Row)


For i = 2 To lastrow
ThisValue = Cells(i, "A").Value
'Vessel 1
If ThisValue = "Vessel 1" Then
Set rng1 = Range(Cells(i, "A"), (Cells(i, "A").End(xlToRight)))


ElseIf ThisValue = "Blood Vessel 2" Then
Set rng2 = Range(Cells(i, "A"), (Cells(i, "A").End(xlToRight)))
Set Rng3 = Range(rng1, rng2.Offset(-1))
Rng3.Copy
ActiveSheet.Name = "Imported Data"
Worksheets.Add After:=Worksheets(Sheets.Count)
With ActiveSheet
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
.Paste
.Name = "BV1"

End With
Sheets("Imported Data").Select
'Vessel 2
ElseIf ThisValue = "Vessel 3" Then
Set rng1 = Range(Cells(i, "A"), (Cells(i, "A").End(xlToRight)))
Set Rng3 = Range(rng2, rng1.Offset(-1))
Rng3.Copy
Worksheets.Add After:=Worksheets(Sheets.Count)

With ActiveSheet
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
.Paste
.Name = "BV2"

End With
Sheets("Imported Data").Select
'Vessel 3
ElseIf ThisValue = "Vessel 4" Then
Set rng2 = Range(Cells(i, "A"), (Cells(i, "A").End(xlToRight)))
Set Rng3 = Range(rng1, rng2.Offset(-1))
Rng3.Copy
Worksheets.Add After:=Worksheets(Sheets.Count)
With ActiveSheet
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
.Paste
.Name = "BV3"


End With
Sheets("Imported Data").Select
'Last Vessel
Set rng1 = Range(rng2, Range("A1").End(xlDown))
rng1.Copy
Worksheets.Add After:=Worksheets(Sheets.Count)
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
ActiveSheet.Name = "BV16"

Sheets("Imported Data").Select

End If
Next i
'Copy Title

Dim ws As Worksheet

Sheets("Imported Data").Range(Cells(1, "A"), (Cells(1, "A").End(xlToRight))).Copy
For Each ws In Worksheets
If ws.Name <> "Imported Data" Then
With ws
.Activate
.Range("A1").Select
With ActiveSheet
.Paste
.Columns("A:Z").AutoFit

End With
End With
End If
Next
End Sub