Macro VBA envío de ficheros adjuntos

Me gustaría hacer un envío masivo a través de excel a diferentes destinatarios, con adjuntos que se encuentran en diferentes rutas. Es decir, cada destinatario tiene una carpeta con su nombre con diferentes tipos de ficheros dentro de esas carpetas, y necesito que en función del nombre vaya a esa carpeta y adjunte en el mail todos los archivos.

Esta es la macro que tengo, que me envía el correo pero no me adjunta nada:

       For i = 2 To 60000

            If Sheets("PROCURADORES").Range("A" & i) <> "" Then

                 strDestinatario = Sheets("PROCURADORES").Range("A" & i)

                strnombreprocurador = Sheets("PROCURADORES").Range("A" & i)

                strNombreFichero = strnombreprocurador

                    Set rng = Sheets("Carta").Range("A1: A40")   

                    Set objOL = New Outlook.Application

                    Set objMail = objOL.CreateItem(olMailItem)

                    With objMail

                        .To = Sheets("PROCURADORES").Range("H" & i) ' cambia al destinatario de correo que desees

                        .Subject = Sheets("Boton").Range("J5")

                        .SentOnBehalfOfName = "[email protected]"

                        On Error GoTo EnvioMalo

                    .Attachments.Add "ruta\" & strNombreFichero & "\" & arch

                        arch = Dir("*.*")

                        arch = Dir()

                        .HTMLBody = RangetoHTML(rng)

                        .HTMLBody = Replace(.HTMLBody, "align=center x:publishsource=", "Align=left x:publishsource=")

                        .Send   'or use .Display

                    End With

                    Set objMail = Nothing

                    Set objOL = Nothing

            Else

                i = 61000

            End If

        Next i