How to loop concatenate separately, groups of rows with VBA?

In the section commented "THIS LINE is ignoring the sequence".

The second loop concatenates rows 9 to 1608 instead of 809 to 1608.
The third loop concatenates rows 9 to 2408 instead of 1609 to 2408.
And so on.

It figures out the endref but there is a problem with the startref.

How to fix this so each x concatenates the following 800 rows?

If you want to try the code: enter link description here

Sub Mailer()

    Sheets("Data").Select
    Range("A5").Value = 0
    Range("A6").Value = 5
    Range("A7").Value = 9
    Range("A8").Value = 808
    Range("G2").Value = ""
       
    loopref = Sheets("Data").Range("A4").Value
    
    For x = 1 To loopref
    
        If Sheets("Data").Range("A5").Value < Sheets("Data").Range("A4").Value Then
       
            'autos
            howlong = Sheets("Data").Range("A6").Value
            startref = Sheets("Data").Range("A7").Value
            endref = Sheets("Data").Range("A8").Value
       
            Dim rng As Range
            Dim i As String
            Dim SourceRange As Range

            ''''''''''''''''''''''''''''''THIS LINE is ignoring the sequence
            Set SourceRange = ThisWorkbook.Sheets(1).Range("B" & startref & ":B" & endref)

            For Each rng In SourceRange
                i = i & rng & "; "
            Next rng
            Sheets("Data").Range("G2").Value = Trim(i)

            Sheets("Welcome").Select
            Dim wd As Object, editor As Object
            Dim doc As Object
            Dim oMail As MailItem
    
            ActiveSheet.Shapes.Range(Array("Object 1")).Select
            Selection.Verb Verb:=xlPrimary
            Set wd = GetObject(, "Word.Application")
            Set doc = ActiveDocument
            doc.Content.Copy
            doc.Close
            Set wd = Nothing

            Set OutApp = CreateObject("Outlook.Application")
            Set oMail = OutApp.CreateItem(olMailItem)
            With oMail
                .Display
                .BCC = Sheets("Data").Range("G2").Value
                .Subject = "Type your subject here"
                .BodyFormat = olFormatRichText
                Set editor = .GetInspector.WordEditor
                editor.Content.Paste
                .DeferredDeliveryTime = DateAdd("n", howlong, VBA.Now)
                .Send
            End With
    
            'adjust autos
            Sheets("Data").Range("A5").Value = Sheets("Data").Range("A5").Value + 1
            Sheets("Data").Range("A6").Value = Sheets("Data").Range("A6").Value + 60
            Sheets("Data").Range("A7").Value = Sheets("Data").Range("A7").Value + 800
            Sheets("Data").Range("A8").Value = Sheets("Data").Range("A8").Value + 800
            Sheets("Data").Range("G2").ClearContents
    
            'reset if exceeds
            If Sheets("Data").Range("A7").Value > 99209 Then
                Sheets("Data").Range("A7").Value = 9
            End If
    
            If Sheets("Data").Range("A8").Value > 100008 Then
                Sheets("Data").Range("A7").Value = 808
            End If

        End If
    Next x

    MsgBox "Sent to Outbox!"
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "Sent to outbox!"

End Sub

You have to reset i to Null String in every loop

'autos
    howlong = Sheets("Data").Range("A6").Value
    startref = Sheets("Data").Range("A7").Value
    endref = Sheets("Data").Range("A8").Value
    i=""