Ejecutar macro solo en una hoja del libro

Tengo un excel con una macro que consiste en darle a un boton, y se envía el texto de esa página en un mail (a unos destinatarios y un asunto concreto, que tu previamente has configurado en la macro).
El problema es que yo copio esa hoja, con ese "botón", de tar manera que tengo muchas hojas en ese libro con "botón", pero cuando le doy a ese boton en la hoja 5, por ejemplo... En lugar se sacar un sólo mail con el contenido de la hoja 5, me salen 5 mails con los contenidos de la hoja 1... 2... 3... 4... Y5...¿Sabes cómo puedo hacer para que al dar al boton en la hoja 5, solo salga el mail con el contenido de la hoja 5?
Te envío la macro (yo no entiendo mucho de esto pero creo que aquí hay más de una...)
Sub Send_Row()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim rng As Range
    Dim Ash As Worksheet
    Set Ash = ActiveSheet
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then
            Ash.Range("A1:O100").AutoFilter Field:=2, Criteria1:=cell.Value
            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Grades Aug"
                .HTMLBody = RangetoHTML(rng)
                .Display  'Or use Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
            Ash.AutoFilterMode = False
        End If
    Next cell
cleanup:
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

1 Respuesta

Respuesta
1
En éste código no parece que imprima varias hojas, simplemente la hoja activa.
A parte de éste código tiene que tener mas código en la macro, si puede intente agregarmelo para comprobarlo.
Perdón pero es que creo que me he confundido de macro. Es esta:
ub Outlook_Mail_Every_Worksheet_Body()
' Working in Office 2000-2007
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Range("C1").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = ws.Range("C1").Value
                .CC = ""
                .BCC = ""
                .Subject = ws.Range("C2").Value
                .HTMLBody = RangetoHTML(ws.UsedRange)
                .Display    'or use .Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next ws
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Te he marcado en negrita lo que creo que habría que cambiar.
Gracias.
Creo que tendrias que quitar el For y poner esto: te pongo como quedaria todo
ub Outlook_Mail_Every_Worksheet_Body()
' Working in Office 2000-2007
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    ws=ActiveWorkbook.ActiveSheet
        If ws.Range("C1").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = ws.Range("C1").Value
                .CC = ""
                .BCC = ""
                .Subject = ws.Range("C2").Value
                .HTMLBody = RangetoHTML(ws.UsedRange)
                .Display    'or use .Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If 
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Bueno.
Pues he cambiado todo el módulo, tal y como me lo has escrito, y no me deja ejecutar la macro. Se marca en amarillo " ws=ActiveWorkbook.ActiveSheet" y me sale una ventana que dice: "Este comando detendrá el depurador", y se cierra...
Gracias
¿Me podrias pegar de nuevo todo el código tal y como lo dejaste? Es para comprobar el fallo.
Al final ha quedado así...pero tampoco funciona...
Sub Outlook_Mail_Every_Worksheet_Body()
' Working in Office 2000-2007
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Range("C1").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = ws.Range("C1").Value
                .CC = ""
                .BCC = ""
                .Subject = ws.Range("C2").Value
                .HTMLBody = RangetoHTML(ws.UsedRange)
                .Display    'or use .Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next ws
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Gracias.
Perdona pero es que no pude comprobar lo que hice, me guié por lo que creía mas oportuno. Pero ya lo pude probar y funciona, solo manda la hoja activa, este es el código completo que tienes que poner dentro de la función:
' Working in Office 2000-2007
    Dim OutApp As Object
    Dim OutMail As Object
    'Dim ws As Worksheet
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    'ws = ActiveWorkbook.ActiveSheet
    'MsgBox ws
        If Range("C1").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = Range("C1").Value
                .CC = ""
                .BCC = ""
                .Subject = Range("C2").Value
                .HTMLBody = RangetoHTML(UsedRange)
                .Display    'or use .Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

Pruébalo, ahora si funciona.
Hola,
Pues a mi me sigue dando error. Marca la linea de "With" y dice: error de compilación. El procedimiento externo no es válido...
¿Me puedes enviar tú el archivo excel en donde te ha salido, por favor? Mi dirección es (xxxxxx)
Muchisimas gracias
Lo probé en una hoja de excel que cree para probarlo, con correos electronicos que es lo que verifica en la casilla C1, ¿no?
Bueno, no te lo comenté antes porque creia a lo mejor lo habias hecho, ¿pero... has cargado la referéncia de microsoft outlock library? Puede que te dé el error en el with porque no te reconoce el objeto, puede ser, si no, te mandaré otra hoja excel.
Avisame.
Hola.
Pues la verdad es que no he creado nada. Como puedes comprobar, no tengo mucha idea de como funcionan las macros. Pensé que era tan sencillo como pegar la "formula" en el módulo correspondiente...pero veo que la cosa se complica. Te cuento: en el Visual Basic, hay una serie de hojas que aparecen vacias. Despues hay unos módulos, entiendo que cada uno contiene una macro diferente (ya que es un fichero que me descargué de internet, ya hecho con un monton de macros interesantes para mi trabajo)...Pero hay un modulo que se llama "Function module" que contiene esto y que creo debe ser esto a lo que te refieres...¿no?
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
El código utilizado es el siguiente, está comprobado y funcionando.
' Working in Office 2000-2007
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    'For Each ws In ActiveWorkbook.Worksheets
        If Range("C1").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = Range("C1").Value
                .CC = ""
                .BCC = ""
                .Subject = Range("C2").Value
                .HTMLBody = RangetoHTML(ActiveSheet.UsedRange)
                .Display    'or use .Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    'Next ws
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Enviar correo desde excel con otro remitente

Quisiera que me brindes tu apoyo con este inconveniente. Quiero enviar mensajes desde excel con macros. Sin embargo en el trabajo manejo 2 correos uno personal y otro del área donde laboro. Por ejemplo Correo personal: [email protected] correo del...
1 respuesta

Ejecutar macro una sola vez

Tengo el siguiente macro para que cuando el resultado de una fórmula me de "-1" ejecute otro macro que me envía un mail automáticamente y a la vez, me indica en la columna siguiente a la fórmula que me ha enviado el mail. El problema es que cada vez...
1 respuesta

¿Macro para mandar mail con outlook al hacer click en un Commandbutton?

Estoy terminado un macro que consiste en una secuencia de preguntas el punto es que al momento de terminar las preguntas aparece en un UserForm un CommandButton con la opción de Guardar/Enviar, resulta que al hacer click en el, se debe guardar una...
1 respuesta

Macro para mandar correos Outlook

Tengo programada una macro para que me mande correos apretando un botón, en los cuales se adjunta el archivo excel desde donde se ejecuta la macro. El código es el siguiente Private Sub ENVIAR_Click() 'Working in 2000-2007 'This example send the last...
1 respuesta

Sacar subotales por año arriba en la hoja

Ayudarme a que arriba aparezcan los totales por año de cada inquilino que vayamos a consultar Gracias Sub Buscar() 'Mod.Por.DAM Application.ScreenUpdating = False Set h1 = Sheets("Estados de cuenta") Set h2 = Sheets("Cartera.") '...
1 respuesta

En excel, dos macros, crear pdf con la hoja 1 y adjunatrla y enviarla por mail

Tengo problemas, no me reconoce que archivo adjuntar! Sub ReportePDF() On Error Resume Next Dim NombreArchivo As String NombreArchivo = Sheets("Pedidos del mes").Range("b2").Value Sheets("Pedido").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _...
1 respuesta

Enviar mail con pdf adjunto desde excel. Macro.

Tengo un código en Visual Basic para que desde un archivo excel (p.e. Factura) ésta se convierta en un .pdf y automáticamente se anexe en un correo de outlook, listo para enviar. Está tomada de un tutorial de youtube pero me da error al ejecutarla....
2 respuestas