Adjuntar archivos a un correo con condicion.

[muyayito]

Buenas a todo el foro.

En una macro adjunto un archivo para enviar por correo de esta forma:

adjunto = ActiveWorkbook.Path & "\" & Hoja1.[M3] & "\" & Hoja1.[M2] & "\CS_report.pdf
.Attachments.Add adjunto

Como lo haría para insertar todos los pdf que empiecen por "CS"?

Gracias por adelantado.

[Antoni]

Sustituye el código que has subido por este, a ver si hay suerte.

Dim MiPc, Carpeta, Ruta, Archivos, Archivo
Set MiPc = CreateObject("Scripting.FileSystemObject")
Ruta = ActiveWorkbook.Path & "\" & Hoja1.[M3] & "\" & Hoja1.[M2] & "\"
Set Carpeta = MiPc.GetFolder(Ruta)
Set Archivos = Carpeta.Files
For Each Archivo In Archivos
    If Left(Archivo.Name, 2) = "CS" Then
      .Attachments.Add Archivo, 1
    End If
Next

 

[muyayito]

Hace 15 horas, Antoni dijo:

Sustituye el código que has subido por este, a ver si hay suerte.

      .Attachments.Add Archivo, 1
   

 

Buenos dias Don Antoni.

Ppeleándome con tu código me sale el siguiente error:

"El objeto no admite esta propiedad"

[muyayito]

He activado la referencia MIcrosoft.Scripting.Running y despues del error, se me cierra el excel 😅

[Antoni]

Sube tu archivo.

[muyayito]

Hace 9 minutos , Antoni dijo:

Sube tu archivo.

No soy premium Antoni 🥺 Aparte es un gestor de correo que se llama groupwise, que no creo que lo tengas y necesita libreria para referencia.

Estoy pensando que una solucion seria listar en una columna los archivos de la carpeta y cogerlos de ahi...

Edited August 26, 2022 by muyayito

[muyayito]

Solucionado. Gracias Antoni como siempre por la ayuda.

Sub LISTAR_ARCHIVOS()
    Hoja4.Activate
    Dim Ruta As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Ruta = ActiveWorkbook.Path & "\" & Hoja1.[M3] & "\" & Hoja1.[M2] & "\"
    
    Set CARPETA = fso.GetFolder(Ruta)
    Set ficheros = CARPETA.Files
    
    [A1].Value = Ruta
    
    Range("A2").Select
    For Each Archivo In ficheros
If Left(Archivo.Name, 2) = "CS" Then

ActiveCell = Archivo.Name

ActiveCell.Offset(1, 0).Select
End If
Next Archivo
    ActiveCell.EntireColumn.AutoFit
    
    Set fso = Nothing
    Set CARPETA = Nothing
    Set ficheros = Nothing
    Application.ScreenUpdating = True
    End Sub

Esta parte es tuya

 'Assign Attachment(s)
        For Each Archivo In Hoja4.Range("A2:A" & Hoja4.Range("A" & Rows.Count).End(xlUp).Row)
   .Attachments.Add Hoja4.[A1] & Archivo
Next