Loop stops after reaching Email.send line without any error - excel

Question

I made a code, to send multiple emails based on a manual selection.
My problem is that when I'm reaching the .send email, the code does not go to the next "For" value. It sends the email, the loop stops, and the code starts from the beginning without following my For instruction anymore.
Here is my code:
Sub MailTenders()
' add ref - tool -> references - > Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim Email As Outlook.MailItem
' add ref - tool -> references - > Microsoft Word XX.X Object Library
Dim wdDoc As Word.Document '<=========
Dim tempWB As Workbook
Set tempWB = ActiveWorkbook
Dim sht As Excel.Worksheet
Set sht = tempWB.Sheets("Email")
Dim rng As Range
Set rng = sht.Range("A1:N22").SpecialCells(xlCellTypeVisible)
'rng.Copy
Dim reg As Excel.Worksheet
Dim com As Excel.Worksheet
Dim edata As Excel.Worksheet
Dim lstrow As Range
Dim lastr_nr As Long
Dim lastc_nr As Long
Set reg = tempWB.Sheets("Register")
Set com = tempWB.Sheets("Companies")
Set edata = tempWB.Sheets("Email Data")
Dim iCounter As Integer
Dim usermail As String
Dim compny As String
Dim atchm As String
Dim emailrng As Range, cl As Range
Dim sto As String
Dim lc As Integer
com.Activate
lc = Application.CountA(com.Range("A:A"))
For iCounter = 2 To lc 'WorksheetFunction.CountA(Columns(1))
If Cells(iCounter, 6).Value = "x" Then
Set olApp = New Outlook.Application
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
usermail = Cells(iCounter, 5).Value
compny = Cells(iCounter, 2).Value
atchm = Cells(iCounter, 4).Value
reg.Activate
Range("A1").Select
Selection.End(xlDown).Select
Set lstrow = ActiveCell
lastr_nr = ActiveCell.Row
Range("a" & lastr_nr + 1).Value = Range("a" & lastr_nr) + 1
Range("b" & lastr_nr + 1).Select
ActiveCell.FormulaR1C1 = "=NOW()"
ActiveCell.Copy
ActiveCell.PasteSpecial (xlPasteValues)
Range("c" & lastr_nr + 1).Value = compny
Range("d" & lastr_nr + 1).Value = atchm
edata.Activate
Range("B9").Select
Set emailrng = Range(Selection, Selection.End(xlToRight))
lastc_nr = ActiveCell.Column
sto = ""
For Each cl In emailrng
sto = sto & ";" & cl.Value
Next
sto = Mid(sto, 2)
com.Activate
rng.Copy
With Email
.To = usermail
.CC = sto
.Subject = "Cerere oferta pentru proiectul " & edata.Range("B1").Value
wdDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
' .Display
.Attachments.Add "c:\Users\HorbaniucVla\OneDrive - Strabag BRVZ GmbH\BL 2019\CJV Vintu - Simeria\14. Tenders\02. CP\Atasamente\" & atchm & ".zip"
.SaveAs "c:\Users\HorbaniucVla\OneDrive - Strabag BRVZ GmbH\BL 2019\CJV Vintu - Simeria\14. Tenders\02. CP\Offers Sent\" & edata.Range("b10") & ".msg", OlSaveAsType.olMsg
.send '!!!Here the code stops after sending the first email !!!
End With
reg.Activate
Range("e" & lastr_nr + 1).Select
Range("e" & lastr_nr + 1).Hyperlinks.Add Anchor:=Selection, Address:="c:\Users\HorbaniucVla\OneDrive - Strabag BRVZ GmbH\BL 2019\CJV Vintu - Simeria\14. Tenders\02. CP\Offers Sent\" & edata.Range("b10") & ".msg", TextToDisplay:="draft email link"
Range("f" & lastr_nr + 1).Select
Range("e" & lastr_nr + 1).Hyperlinks.Add Anchor:=Selection, Address:="c:\Users\HorbaniucVla\OneDrive - Strabag BRVZ GmbH\BL 2019\CJV Vintu - Simeria\14. Tenders\02. CP\Atasamente\" & atchm & ".zip", TextToDisplay:="attachement link"
End If
Next iCounter
End Sub
For a better understanding, I also made a GIF with the code step into which unfortunately it is bigger than 2mb and I will share via dropbox.
The GIF is animated, but I noticed is not working without download.