Macro does the Display and Sent 1st email but then Error

Hello all,

Please, Im trying to send a bulk email and I would need help for an error that does not let me send more than 1 email. (I attached the file)

My Macro has 3 parts.

MACRO 1 - First I copy a all data base from one sheet to other:

Sub Reponer_BaseDados()
'
    Sheets("Base Dados ").Select
    Columns("B:D").Select
    Selection.Copy
    Sheets("Copia to Macro").Select
    Range("B1").Select
    ActiveSheet.Paste
End Sub

MACRO 2 - Macro for send email

Sub PrepararMailInicial()

Dim ThisFile As String

    col = Range("J1").Column
    For i = 2 To Range("D" & Rows.Count).End(xlUp).Row
        Set mail = CreateObject("outlook.application").CreateItem(0)
        mail.To = Range("D" & i)
        mail.CC = Range("E" & i)
        mail.BCC = Range("F" & i)
        mail.Subject = Range("G" & i)
        mail.body = Range("H" & i)
   ThisFile = "C:\BusCard.png"
        mail.Attachments.Add ThisFile, olByValue, 0
        mail.HTMLBody = Range("H8").Value & "<br>" & _
                        Range("H9").Value & "<br>" & _
                        Range("H10").Value & "<br>" & _
                        Range("H11").Value & "<br>" & _
                        Range("H12").Value & "<br>" & _
                        Range("H13").Value & "<br>" & _
                        Range("H14").Value & "<br>" & _
                        Range("H15").Value & "<br>" & _
                        Range("H16").Value & "<br>" & _
                        Range("H17").Value & "<br>" & _
                        Range("H18").Value & "<br>" & _
                        Range("H19").Value & "<br>" & _
                        Range("H20").Value & "<br>" & _
                        Range("H21").Value & "<br>" & _
                        Range("H2").Value & "<br>" & _
                        Range("H3").Value & "<br>" & _
                        Range("H4").Value & "<br>" & _
                        Range("H5").Value & "<br>" & _
                        Range("H6").Value & "<br>" & _
                        "<img src=""cid:BusCard.png""height=201 width=320>"

        For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
            archivo = Cells(i, j)
                If archivo <> "" Then mail.Attachments.Add archivo
        Next
        mail.Display 'display but not send
        'mail.Send 'send mail

        Next
    'MsgBox "Todos os emails enviados", vbInformation, "BR"
End Sub

PS: between the lines "Range("H2").Value & "<br>" & _" and "Range("H3").Value & "<br>" & _" should be a line that is format of the text but it denies the access to include it on the text.


MACRO 3 - To try to avoid problems of outlook block, I divide the list in packs of 50 and cut/paste

Sub Copiar_Mail_Info_A_Enviar()

    Sheets("Copia to Macro").Select

    k = 2
        Do Until IsEmpty(Cells(k, 2))
        Sheets("Copia to Macro").Select
        Range("B2:D6").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Hoja1").Select
        Range("B3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Copia to Macro").Select
        Rows("2:6").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlUp
        Sheets("Hoja1").Select
        Call PrepararMailInicial
        k = k + 1
    Loop
End Sub

I did a test with only 15 emails and send in packs of 5. The emails appear but error when sent on this line on Macro 2:

        Set mail = CreateObject("outlook.application").CreateItem(0)

Also please on this line of the Macro 2,

        mail.HTMLBody = Range("H8").Value & "<br>" & _

I would like to add to this the name of the company according the lines. Something similar with:

       mail.HTMLBody = Range("H8").Value & "<br>" & Range("B" & i).value & _

But also appear error. This mus be a silly error anyway.

Thank you very much for your help.

Cheers