Mail lista distribución. Si cambio de sitio la columna insertar archivo me da error la referencia no es valida

Te anexo las macros actualizadas, incluso para versión excel 2010.

La macro del módulo "Enviar_Correos"

Sub Enviar_Correos()
'---
'   Por.Dante Amor
'---
    '***Macro Para enviar correos
    col = Range("P1").Column
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
        Set dam = CreateObject("Outlook.Application").CreateItem(0)
        '
        dam.To = Range("B" & i).Value           'Destinatarios
        dam.Cc = Range("C" & i).Value           'Con copia
        dam.Bcc = Range("D" & i).Value          'Con copia oculta
        dam.Subject = Range("E" & i).Value      '"Asunto"
        dam.Body = Range("F" & i).Value         '"Cuerpo del mensaje"
        '
        For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
            archivo = Cells(i, j).Value
            If archivo <> "" Then dam.Attachments.Add archivo
        Next
        'dam. Send 'El correo se envía en automático
 dam. Display 'El correo se muestra
    Next
    MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub

Las macros para los eventos de la hoja:

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
On Error Resume Next
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    For Each t In Target
        If t.Value <> "" Then
            Cells(t.Row, "P").Select
            ActiveSheet.Hyperlinks.Add _
                Anchor:=Selection, _
                Address:="", _
                SubAddress:="Hoja1!C" & t.Row, _
                TextToDisplay:="Insertar archivo"
        End If
    Next
    Cells(Target.Row, 3).Select
End If
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Por.Dante Amor
    linea = ActiveCell.Row
    'col = Range("H1").Column
    col = Cells(linea, Columns.Count).End(xlToLeft).Column + 1
    If col < Columns("P").Column Then col = Columns("P").Column
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione uno o varios archivos"
        .Filters.Clear
        .Filters.Add "archivos pdf", "*.pdf*"
        .Filters.Add "archivos de excel", "*.xls*"
        .Filters.Add "Todos los archivos", "*.*"
        .FilterIndex = 2
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path
        If .Show Then
            For Each ar In .SelectedItems
                'rutaarchivo = .SelectedItems.Item(i)
                Cells(linea, col) = ar
                col = col + 1
            Next
        End If
    End With
End Sub

Si quieres el nuevo archivo, envíame un correo a

[email protected]

En el asunto del correo escribe tu nombre de usuario “Eduardo Martinez”

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

¡Gracias! 

Hola. Tema solucionado. Muchas gracias por tu ayuda.

Hola.

He tenido que añadir más columnas y me vuelve a salir el error "La referencia no es válida"

Las macros las tengo así, simplemente traslado tu código a la nueva disposición de las columnas pero está claro que algo me dejo y no sé que es. 

en la hoja de nombre PEDIDOS tengo este código

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dam
On Error Resume Next
If Not Intersect(Target, Range("O:O")) Is Nothing Then 'XXX Range("O:O") Columna Para
For Each t In Target
If t.Value <> "" Then
Cells(t.Row, "R").Select 'XXX "R" Columna Insertar archivo
ActiveSheet.Hyperlinks.Add _
Anchor:=Selection, _
Address:="", _
SubAddress:="PEDDOS!C" & t.Row, _
TextToDisplay:="Insertar archivo" 'XXX "PEDIDOS!C" Es el nombre de la hoja y la columna N es la columna Copia Para
End If
Next
Cells(Target.Row, 3).Select
End If
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Por.Dam
linea = ActiveCell.Row
col = Range("S1").Column 'XXX Columna S1 es la columna del Archivo 1 adjunto
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione uno o varios archivos"
.Filters.Clear
.Filters.Add "archivos pdf", "*.pdf*"
.Filters.Add "archivos de excel", "*.xlsx*"
.Filters.Add "archivos de macros de excel", "*.xlsm*"
.Filters.Add "Todos los archivos", "*.*"
.FilterIndex = 2
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path
If .Show Then
For Each ar In .SelectedItems
'rutaarchivo = .SelectedItems.Item(i)
Cells(linea, col) = ar
col = col + 1
Next
End If
End With
End Sub

Y en el módulo 1 tengo este código

'***Macro Para enviar correos
Sub correo()
'Por.Dante Amor
Dim NumMail As Integer

NumMail = 0
col = Range("S1").Column 'XXX Columna S es la columna del Archivo 1 adjunto
For i = 2 To Range("O" & Rows.Count).End(xlUp).Row 'XXX Columna O es columna Para
If Range("J" & i).Value = 1 Then 'XXX Si en la columna I tenemos el valor 1 manda el mail, si no, No lo envía
NumMail = NumMail + 1
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = Range("O" & i) 'XXX Destinatarios Columna Para
dam.CC = Range("P" & i) 'XXX Con copia
dam.Bcc = Range("Q" & i) 'XXX Con copia oculta
dam.Subject = Range("G" & i) 'XXX "Asunto"
dam.body = Range("H" & i) 'XXX "Cuerpo del mensaje"
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j)
If archivo <> "" Then dam.Attachments.Add archivo
Next
dam.send 'El correo se envía en automático y no se muestra
'dam.display 'El correo se muestra para repasar y ser enviado
Range("J" & i).Value = "Enviado" 'XXX En la columna I ponemos Enviado en la fila que hemos enviado el mail
End If
Next
MsgBox "" & NumMail & " Mail Enviados", vbInformation, "Mail Enviado OK"
End Sub

Todo funciona perfectamente incluso después de mostrarme el error "la referencia no es válida" pero ya que está todo tan bien conseguido me molesta que salga. Gracias por la atención.

A ver si me puedes ayudar, por favor.

Lo único raro que veo es que en esta línea te falta la letra "i"

SubAddress:="PEDDOS!C" & t.Row, _

Debería ser:

SubAddress:="PEDIDOS!C" & t.Row, _

Hola.

Ya lo he puesto así y nada

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dam
On Error Resume Next
If Not Intersect(Target, Range("O:O")) Is Nothing Then 'XXX Range("O:O") Columna Para
For Each t In Target
If t.Value <> "" Then
Cells(t.Row, "R").Select 'XXX "R" Columna Insertar archivo
ActiveSheet.Hyperlinks.Add _
Anchor:=Selection, _
Address:="", _
SubAddress:="PEDIDOS!C" & t.Row, _
TextToDisplay:="Insertar archivo" 'XXX "PEDIDOS!C" Es el nombre de la hoja y la columna N es la columna Copia Para
End If
Next
Cells(Target.Row, 3).Select
End If
End Sub

¿hay alguna manera de que yo te envíe el archivo para que puedas verificar dónde está el fallo? Muchas gracias.