Ejecutar macro solo en una hoja del libro

Question

el 17 nov. 10

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

neicos, Analista de sistemas y Programador en: Basic,c,c++,visual... · Accepted Answer · 2010-11-17T16:39:34.0000000Z

Respuesta de neicos

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.

el 17 nov. 10

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.

el 17 nov. 10

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.

el 17 nov. 10

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

el 18 nov. 10

¿Me podrias pegar de nuevo todo el código tal y como lo dejaste? Es para comprobar el fallo.

el 18 nov. 10

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.

el 22 nov. 10

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.

el 23 nov. 10

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

el 23 nov. 10

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.

el 23 nov. 10

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 24 nov. 10

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

el 3 dic. 10

Ejecutar macro solo en una hoja del libro

1 Respuesta

Añade tu respuesta

Más respuestas relacionadas

Enviar correo desde excel con otro remitente

Ejecutar macro una sola vez

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

Macro para mandar correos Outlook

Sacar subotales por año arriba en la hoja

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

Enviar mail con pdf adjunto desde excel. Macro.

¿Cómo cambiar PC a un habitación diferente a donde está conexión de fibra?

Sobre las cookies en página web

¿Me pueden espiar el WhatsApp?

¿Cómo puedo editar un documento fotografiado?