SelectionChange en VB Excel se queda en un bucle

Tengo un código dentro del Sub SelectionChange el cual me permite copiar un renglón debajo del mismo y escanear un código después si este es el correcto vuelve a copiar el renglón y lo pega debajo y así sucesivamente, lo malo es que realiza la comparación desde el primer renglón hasta llegar al que se quedo y se cancela el escaneo al llegar al numero 28 y se queda encerrado ahí y no continua copiando

Les dejo el código:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (SelectCase = 0) Then
NumberColumnA = "B"
NumberColumnB = "G"
Batch = Range("D3").Value
TotalPieces = Range("F3").Value
TotalBox = Range("E4").Value
SalesCarton = Range("E5").Value
SalesCarton = SalesCarton + 1
CounterPouch = 1
CounterBox = 0
SelectCase = 1
Counter = 1
NumberColumn = "C"
NumberRow = 7
NumberCell = NumberColumn & NumberRow
End If
If (SelectCase = 1) Then
If (CounterBox = TotalBox) Then
Range("F4").Select
Selection.ClearContents
Range("F4").Select
End
Else
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
If (Range(NumberCell).Value = "") Then
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
Else
If (Counter = SalesCarton) Then ' Sales Carton Pouch Scanning
CodeBox = Left(Range(NumberCell).Value, 4)
If (CodeBox = "0110") Then
BatchLabel = Right(Range(NumberCell).Value, 10)
If (BatchLabel = Batch) Then
CounterBox = CounterBox + 1
Counter = 1
NumberColumn = "G"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Value = "PASA"
Range(Cells(NumberRow, NumberColumnA), Cells(NumberRow, NumberColumnB)).Copy
NumberRow = (NumberRow + 1)
NumberColumn = "B"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
Selection.PasteSpecial
Selection.ClearContents
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
Selection.Value = CounterPouch
NumberColumn = "C"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
End
Else
NumberColumn = "G"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Value = "NO PASA"
NumberColumn = "F"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
MsgBox "Codigo Incorrecto", vbCritical
End
End If
Else
If (Range(NumberCell).Value <> "") Then
NumberColumn = "G"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Value = "NO PASA"
NumberColumn = "F"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
MsgBox "Etiqueta Erronea", vbCritical
End
Else
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
End
End If
End If
Else ' Label Pouch Scanning
CodePouch = Left(Range(NumberCell).Value, 4)
If (CodePouch = "0100") Then
BatchLabel = Right(Range(NumberCell).Value, 10)
If (BatchLabel = Batch) Then
Counter = Counter + 1
CounterPouch = CounterPouch + 1
NumberColumn = "D"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Value = "PASA"
If (Counter < SalesCarton) Then
Range(Cells(NumberRow, NumberColumnA), Cells(NumberRow, NumberColumnB)).Copy
NumberRow = (NumberRow + 1)
NumberColumn = "B"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
Selection.PasteSpecial
Selection.ClearContents
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
Selection.Value = CounterPouch
NumberColumn = "C"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
End
Else
NumberColumn = "F"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
End
End If
Else
NumberColumn = "D"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Value = "NO PASA"
NumberColumn = "C"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
MsgBox "Codigo Incorrecto", vbCritical
End
End If
Else
If (Range(NumberCell).Value <> "") Then
NumberColumn = "D"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Value = "NO PASA"
NumberColumn = "C"
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
MsgBox "Etiqueta Erronea", vbCritical
End
Else
NumberCell = (NumberColumn & NumberRow)
Range(NumberCell).Select
End
End If
End If
End If
End If
End If
End If
End Sub