copier la liste des tableaux dans le corps de l'email

Question

J'essaie d'afficher le résultat d'un tableau dans le corps d'un courriel, mais j'obtiens un message d'erreur indiquant que l'indice est hors de portée.

Je n'ai pas encore bien compris la manipulation des tableaux et j'ai donc du mal à résoudre cette erreur.

Quelqu'un peut-il m'aider ?

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

Answer 1

Copier le tableau dans le corps du courriel

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

Answer 2

J'ai compris que dans la boucle do while il ne faut que y<x et non y<=x et j'ai effacé le corps,y,x, redim sq(x) puisqu'il sera réutilisé dans la boucle for

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