Excel freezes after first Sub

I have the following Code that should give me for every User a copy to another Worksheet. As the input data for every varies, I have to define the ranges with the appearances of Usernames. Unfortunately, the last one does not work (Where "Total" stands for the last row containing data)and if comment the last one out, Excel freezes after the first Sub SelectRange() although they work individually. Can someone help here?

Here is the Code:

Sub Main()
Call SelectRangeUser1
Call SelectRangeUser2
Call SelectRangeUser3
Call SelectRangeUser4
Call SelectRangeUser5
Call SelectRangeUser6
Call SelectRangeUser7
Call SelectRangeUser8
End Sub
Sub SelectRangeUser1()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User1" 
searchStringEnd = "User2" 
searchStringStop = "User2" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User1"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User1"
End If
End Sub
Sub SelectRangeUser2()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User2" 
searchStringEnd = "User3" 
searchStringStop = "User3" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User2"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User2"
End If
End Sub
Sub SelectRangeUser3()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User3" 
searchStringEnd = "User4"
searchStringStop = "User4"
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User3"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User3"
End If
End Sub
Sub SelectRangeUser4()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User4" 
searchStringEnd = "User5" 
searchStringStop = "User5" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User4"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User4"
End If
End Sub
Sub SelectRangeUser5()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User5"
searchStringEnd = "User6" 
searchStringStop = "User6" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User5"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User5"
End If
End Sub
Sub SelectRangeUser6()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User6" 
searchStringEnd = "User7" 
searchStringStop = "User7" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User6"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User6"
End If
End Sub
Sub SelectRangeUser7()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
Dim startStringCount As Integer ' counter for the number of times the start string is found
searchStringStart = "User7" ' change this to your specific start string
searchStringEnd = "User8" ' change this to your specific end string
searchStringStop = "User8" ' change this to your specific stop string
startStringCount = 0 ' initialize start string count to zero
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
startStringCount = startStringCount + 1 ' increment start string count
If startStringCount = 2 Then ' if this is the second appearance of the start string
Set startCell = currentCell
Exit For
End If
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add ' create a new worksheet
newSheet.Name = "User7" ' assign a name to the new worksheet
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11) ' resize the selected range to include columns A to K
newRange.Copy newSheet.Range("A1") ' copy the selected range to the new worksheet
newRange.Name = "User7" ' assign a name to the selected range
End If
End Sub
Sub SelectRangeUser8()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
Dim lastStartCell As Range ' variable to store the last cell where the start string was found
searchStringStart = "User8" 
searchStringEnd = "Total"
searchStringStop = "Total"
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set lastStartCell = currentCell ' update the last cell where the start string was found
If startCell Is Nothing Then
Set startCell = currentCell
End If
End If
Next currentCell
' if start string is found, search for the end or stop string after the last cell where the start string was found
If Not lastStartCell Is Nothing Then
For Each currentCell In ActiveSheet.Range(lastStartCell.Offset(1), ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
End If
Next currentCell
End If
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add ' create a new worksheet
newSheet.Name = "User8" ' assign a name to the new worksheet
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11) ' resize the selected range to include columns A to K
newRange.Copy newSheet.Range("A1") ' copy the selected range to the new worksheet
newRange.Name = "User8" ' assign a name to the selected range
End If
End Sub

As already explained, I tried to set up a routine to identify changing ranges from an input and copying it to a new Worksheet in the same Workbook.

I wasn't sure whether to post this as it doesn't answer why your code is freezing - it does show a better and shorter way to search for all users providing there's no gaps in the numbering.
If there are gaps you'd have to change the username look up - maybe a unique list of names in your data and search through that (UNIQUE formula if you've got 365).

This doesn't check for existing worksheets with the same name, so maybe put an error handler in for that.

Sub Extract()
Dim SearchString As String
SearchString = "User"
Dim UserNum As Long
UserNum = 1
'Any range in this block that starts with . is refering to column A
'in Sheet1 of the workbook containing this code.
With ThisWorkbook.Worksheets("Sheet1").Columns(1)
Dim foundStart As Range
Dim foundEnd As Range
Do
'Find the first and last occurrence of the user name (xlNext, xlPrevious).
'Note - user names start on row 2, with heading on row 1.
'The search starts AFTER the first cell ( .Cells(1,1) )
Set foundStart = .Find(SearchString & UserNum, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)
Set foundEnd = .Find(SearchString & UserNum, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious)
'If the range is found then create a new sheet and copy the data to it.
If Not foundStart Is Nothing Then
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = SearchString & UserNum
.Range(foundStart, foundEnd).Resize(, 11).Copy _
Destination:=wrkSht.Cells(1, 1)
End If
'Increase the user name by 1 and search again.
UserNum = UserNum + 1
Loop While Not foundStart Is Nothing
End With
End Sub  

For specific user names you could use the code below. Would be better to pass the user names as an argument though.

Sub Extract()
Dim UsrNames As Variant
UsrNames = Array("Me", "You", "Someone else")
With ThisWorkbook.Worksheets("Sheet1").Columns(1)
Dim UsrName As Variant
For Each UsrName In UsrNames
Dim foundStart As Range
Dim foundEnd As Range
'Find the first and last occurrence of the user name (xlNext, xlPrevious).
'Note - user names start on row 2, with heading on row 1.
'The search starts AFTER the first cell ( .Cells(1,1) )
Set foundStart = .Find(UsrName, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)
Set foundEnd = .Find(UsrName, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious)
'If the range is found then create a new sheet and copy the data to it.
If Not foundStart Is Nothing Then
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = UsrName
.Range(foundStart, foundEnd).Resize(, 11).Copy _
Destination:=wrkSht.Cells(1, 1)
End If
Next UsrName
End With
End Sub