copy array list in to email body

Copy Array to Email Body

Option Explicit

Sub LoopAndSendMail()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the addresses data to a 2D one-based array ('aData').
    Dim aws As Worksheet: Set aws = wb.Worksheets("Addresses")
    Dim alCell As Range: Set alCell = aws.Cells(aws.Rows.Count, "D").End(xlUp)
    Dim arg As Range: Set arg = aws.Range("A2", alCell)
    Dim arCount As Long: arCount = arg.Rows.Count
    Dim aData() As Variant: aData = arg.Value
    
    ' Declare additional variables.
    
    ' Addresses
    Dim ar As Long
    
    ' Body (Location)
    Dim bArr() As String
    Dim bnCount As Long
    Dim bn As Long
    
    ' Location
    Dim lws As Worksheet
    Dim lName As String
    Dim lrg As Range
    Dim lData() As Variant
    Dim lrCount As Long
    Dim lcCount As Long
    Dim lr As Long
    Dim lc As Long
    Dim lString As String
    
    ' Loop through the rows of the addresses data...
    For ar = 1 To arCount
        
        lName = CStr(aData(ar, 4))
        
        ' Attempt to reference the location worksheet ('lws').
        On Error Resume Next
            Set lws = wb.Worksheets(lName)
        On Error GoTo 0
        
        If Not lws Is Nothing Then ' the location worksheet exists
            
            ' Reference the location range ('lrg') (one row of headers).
            Set lrg = lws.UsedRange
            Set lws = Nothing ' reset the variable to reuse in next iteration
            
            lrCount = lrg.Rows.Count
            
            If lrCount > 1 Then ' the location range has more than one row
            
                lcCount = lrg.Columns.Count
                bnCount = (lrCount - 1) * lcCount ' exclude headers (- 1)
                
                ' Write the values from the location range
                ' to a 2D-one based array ('lData').
                lData = lrg.Value
                ' The previous line is so simple because we have made sure
                ' that the range contains more than one row but we have
                ' to make sure that the loop starts with row 2 (see below).
                
                ' Note that the use of the body array can be replaced with
                ' writing to a string (which is possibly even more efficient).
                ' But let's say we are practicing using arrays.
                
                ' Resize the body array to the maximum possible size.
                ReDim bArr(1 To bnCount)
                
                ' Write non-blanks from the location array to the body array.
                For lr = 2 To lrCount ' skip headers (2)
                    For lc = 1 To lcCount
                        lString = CStr(lData(lr, lc))
                        If Len(lString) > 0 Then ' is not blank
                            bn = bn + 1 ' next element
                            bArr(bn) = lString ' write
                        'Else ' is blank; do nothing
                        End If
                    Next lc
                Next lr
                
                If bn > 0 Then ' non-blanks found
                    
                    ' Correct the size of the body array.
                    If bn < bnCount Then ' blanks found
                        ReDim Preserve bArr(1 To bn) ' resize (shrink)
                    'Else ' no blanks found; do nothing i.e. the size is correct
                    End If
                    
                    bn = 0 ' reset the variable to reuse in next iteration
                            
                    ' Email
                    With CreateObject("Outlook.Application").CreateItem(0)
                       .To = CStr(aData(ar, 3))
                       .Subject = CStr(aData(ar, 1)) & " " _
                           & CStr(aData(ar, 2)) _
                           & "-" & lName ' lName = CStr(aData(ar, 4))
                       .Body = "Hi," & vbLf & vbLf & Join(bArr, vbLf)
                       '.Attachments.Add
                       .Display '.Send
                    End With
                    
                'Else ' no non-blanks found; do nothing
                End If
            
            'Else ' the loc. range has only one row or the worksheet is empty
            End If
            
        'Else ' the location worksheet doesn't exist; do nothing
        End If
        
    Next ar
    
End Sub

i figured it out in the in the do while loop should only be y<x not y<=x and cleared the body,y,x, redim sq(x) since it will be reused inside the for loop

Dim sBody, y
Dim location_sheet As String
Dim sq(), ar, x As Long, j As Long, jj As Long


lRow = Worksheets("Addresses").Cells(Rows.Count, 4).End(xlUp).Row

For Each c In Worksheets("Addresses").Range("D2:D" & lRow).Cells

    sBody = "" 'clear coz will be reused inside for loop
    y = 0 'clear coz will be reused inside for loop
    x = 0 'clear coz will be reused inside for loop
    ReDim sq(x) 'clear coz will be reused inside for loop

    location_sheet = c.Value
    ar = Sheets(location_sheet).UsedRange
    
    For j = 1 To UBound(ar)
         For jj = 1 To UBound(ar, 2)
           If ar(j, jj) <> "" Then
               ReDim Preserve sq(x)
               sq(x) = ar(j, jj)
              x = x + 1
             End If
         Next
     Next
    
    sBody = "Hi,"
        Do While y < x
          sBody = sBody & vbNewLine & sq(y)
          y = y + 1
        Loop
    
    With CreateObject("outlook.application").createitem(0)
       .To = c.Offset(0, -1).Value
       .Subject = c.Offset(0, -3).Value & " " & c.Offset(0, -2).Value & "-" & c.Value
       .body = sBody
       '.Attachments.Add
       .display '.send
     End With
     
Next