Enviar mail to y cc segun listado

[jjsm]

Estimados,

Un gusto saludarlos, tal vez el titulo ya les parecerá repetitivo, y hasta la parte del To creo que lo es, porque me he navegado todo en internet y no logro dar con algo para incluirle un Cc.

Me explico.

Tengo una planilla de clientes con su Correo, y el de su vendedor. El envio al cliente con un archivo adjunto ya lo tengo resuelto. (Hay mucho material sobre esto)

Mi problema es enviarlo con copia al supervisor, esto porque además cada supervisor tiene diferentes clientes.

Logre enviar con copia, pero solo al primer correo, al segundo y los siguientes no lo hace y solo envía Para.

Adjunto el código y archivo.

Intente modificando el campo Cc con los siguientes códigos, tal vez hay algo mas que debiera modificar:

.Cc = Cws.Cells(Rnum + 1, 1).Value (Solo envía con copia el primer correo)

.Cc = ActiveSheet.Cells(8, 8).Value (Envia con copia basado en el adjunto, pero tendría que agregar la columna vendedor en el archivo adjunto, y lo quiero evitar)

Tampoco quiero concatenar, porque significa agregar mas columnas a la base.

¿Se podrá?

Sub Envio_EECC()

    Dim OutApp As Object

    Dim OutMail As Object

    Dim rng As Range

    Dim Ash As Worksheet

    Dim Cws As Worksheet

    Dim Rcount As Long

    Dim Rnum As Long

    Dim FilterRange As Range

    Dim FieldNum As Integer

    Dim NewWB As Workbook

    Dim TempFilePath As String

    Dim TempFileName As String

    Dim FileExtStr As String

    Dim FileFormatNum As Long


    uf1 = Range("B1").Value

    uf2 = Range("B2").Value



    On Error GoTo cleanup

    Set OutApp = CreateObject("Outlook.Application")


    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With


    'Set filter sheet, you can also use Sheets("MySheet")

    Set Ash = ActiveSheet


    'Set filter range and filter column (column with e-mail addresses)

    Set FilterRange = Ash.Range("A3:AD" & Ash.Rows.Count)

    FieldNum = 28    'Filter column = 28 because the filter range start in column AB


    'Add a worksheet for the unique list and copy the unique list in A1

    Set Cws = Worksheets.Add

    FilterRange.Columns(FieldNum).AdvancedFilter _

            Action:=xlFilterCopy, _

            CopyToRange:=Cws.Range("A1"), _

            CriteriaRange:="", Unique:=True


    'Count of the unique values + the header cell


    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))


    'If there are unique values start the loop

    If Rcount >= 2 Then

        For Rnum = 2 To Rcount


            'Si el unico valor es un mail, crea un email

            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then


                'Filtra el Range segun el nombre de la columna

                FilterRange.AutoFilter Field:=FieldNum, _

                                      Criteria1:=Cws.Cells(Rnum, 1).Value


                'Copia los datos filtrados en un nuevo libro

                With Ash.AutoFilter.Range

                    On Error Resume Next

                    Set rng = .SpecialCells(xlCellTypeVisible)

                    On Error GoTo 0

                End With


                Set NewWB = Workbooks.Add(xlWBATWorksheet)


                rng.Copy

                With NewWB.Sheets(1)

                    .Cells(7, 1).PasteSpecial Paste:=8

                    .Cells(7, 1).PasteSpecial Paste:=xlPasteValues

                    .Cells(7, 1).PasteSpecial Paste:=xlPasteFormats

                    .Cells(7, 1).Select

                    Application.CutCopyMode = False

            'Aqui pega un logo (quitar los ' para habilitar)

                    Range("A1").Select

                    ActiveSheet.Pictures.Insert("C:\clxlogo-small-color.png").Select


    'Elimina columna con datos innecsarios para el cliente

    Range("A:A,D:E,H:H,J:K,M:P,R:AC").Select

    Selection.Delete Shift:=xlToLeft

    Columns("I:XFD").Select

    Selection.EntireColumn.Hidden = True

    Rows("300:1048576").Select

    Selection.EntireRow.Hidden = True

    'Fijar vista


    'Escribir titulo (Quitar los ' para habilitar)

    Range("G1").Select

    ActiveCell.FormulaR1C1 = "CLOROX Chile S.A"

    Range("G2").Select

    ActiveCell.FormulaR1C1 = "RUT : 96.681.470-5"

    Range("G3").Select

    ActiveCell.FormulaR1C1 = "Av. Americo Vespucio 0701"

    Range("G4").Select

    ActiveCell.FormulaR1C1 = "Quilicura"

    Range("D2").Select

    ActiveCell.FormulaR1C1 = "ESTADO DE CUENTA"

    Range("A1:H5").Select

    Selection.Font.Bold = True

    Range("D2").Select

    Selection.Font.Underline = xlUnderlineStyleSingle

    With Selection

            .HorizontalAlignment = xlCenter

    End With

    ActiveWindow.DisplayGridlines = False

    Range("E6").Select

    ActiveCell.FormulaR1C1 = "Total"

    Range("E6:F6").Select

    Selection.Font.Bold = True

    'Ajustar ancho de columnas

    Cells.Select

    Cells.EntireColumn.AutoFit

    'Total

    Range("F6").Select

    ActiveCell.FormulaR1C1 = "=SUM(R[2]C:R[250]C)"

    Range("A8").Select

    ActiveWindow.FreezePanes = True

                End With


'Incluir lineas divisorias

    Range("A8").Select

    Range(Selection, Selection.End(xlDown)).Select

    Range(Selection, Selection.End(xlToRight)).Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideHorizontal)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    Range("A8").Select

                'Crea un archivo nuevo

                TempFilePath = Environ$("temp") & "\"

                TempFileName = "EECC Clorox al " & Format(Now, "dd-mmm-yy")


                If Val(Application.Version) < 12 Then

                    'You use Excel 2000-2003

                    FileExtStr = ".xls": FileFormatNum = -4143

                Else

                    'You use Excel 2007-2010

                    FileExtStr = ".xlsx": FileFormatNum = 51

                End If


                'Save, Mail, Close and Delete the file

                Set OutMail = OutApp.CreateItem(0)


                With NewWB

                    .SaveAs TempFilePath & TempFileName _

                          & FileExtStr, FileFormat:=FileFormatNum

                    On Error Resume Next


                    With OutMail

                        .To = Cws.Cells(Rnum, 1).Value

                        .Subject = "ESTADO DE CUENTA CLOROX CHILE S.A.(Revisar adjunto)"

                        .Cc = ActiveSheet.Cells(8, 8).Value

                        .Attachments.Add NewWB.FullName

                        .Body = "Estimado," & vbNewLine & _

                                    vbNewLine & vbNewLine & _

                                    uf1 & vbNewLine & _

                                    "Sin otro particular" & vbNewLine & _

                                    vbNewLine & vbNewLine & _

                                    uf2

                        .Send  'Or use Display

                    End With

                    On Error GoTo 0

                    .Close savechanges:=False

                End With


                Set OutMail = Nothing

                Kill TempFilePath & TempFileName & FileExtStr

            End If


            'Close AutoFilter

            Ash.AutoFilterMode = False


        Next Rnum

    End If


cleanup:

    Set OutApp = Nothing

    Application.DisplayAlerts = False

    Cws.Delete

    Application.DisplayAlerts = True


    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

End Sub[/CODE]

[/i]

CARTE RA.rar