i am trying display the result of an array into a body of an email but I get an error subscript out of range
I am not yet well understood in manipulating arrays so Im having trouble solving the error
could anyone help me?
Dim lRow As Long
Dim sBody, y
Dim location_sheet As String
Dim sq(), ar, x As Long, j As Long, jj As Long
y = 2
lRow = Cells(Rows.Count, 4).End(xlUp).Row
For Each c In Worksheets("Addresses").Range("D2:D" & lRow).Cells
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) ' subscript out of range 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
CodePudding user response：
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
CodePudding user response：
i figured it out in the in the do while loop should only be x<y not x<=y 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
y = 2
lRow = 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