como eliminar macros

Hola Héctor:
Te paso todo el código para hacer una copia de una hoja de un libro y
guardarla en el directorio que elija.
Este código creo recordar que es una parte del sr. Walkenbach y otra de KL,
incluso creo que esn su día tambien participaste?. Ahora estoy intentando
aplicarlo al nuevo programa de trabajo de mis comerciales.
Todo me funciona bien salvo el borrado de macros que efectivamente SOLO ha
de hacerse en la copia...
Gracias por tu tiempo.
José Rafael

'--Inicio Codigo
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'Declaraciones 32-bit API
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'Esta funcion muestra el dialogo para eligir directorio.
'Publicada por John Walkenbach.
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Directorio de raiz = Escritorio
bInfo.pidlRoot = 0&

' titulo en el dialogo
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' tipo de directorio a devolver
bInfo.ulFlags = &H1

' mostrar el dialogo
x = SHBrowseForFolder(bInfo)

' extraer el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub archivarhojareporteenmisdocumentos()
'archiva la hoja de reporte en carpeta de Mis documentos
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet
Dim Pass As String
Dim Modulo As VBIDE.VBComponent, _
Modulos As VBIDE.VBComponents
Dim carInvalidos As Variant

Dim MiArchivo As String
'***********************
Dim Insout As New Outlook.Application ' Variable objeto
Outlook
Dim Mimail As Outlook.MailItem ' Variable objeto
mensaje Outlook
Set Mimail = Insout.CreateItem(olMailItem) ' se asigna un nuevo
mensaje a la variable objeto Outlook
Dim i As Integer
Dim NombreUnico As Boolean
Dim NombreValido As Boolean
Application.Run _
"'Programa de reportes y visitas para 2.009.xls'!informesemanal"

'Guarda el libro original para no perder
'los cambios accidentalmente.
ThisWorkbook.Save

'Establecemos la lista de caracteres invalidos.
carInvalidos = Array(":", "\", "/", "?", "*", "[", "]")

'Pedimos al usuario q eliga el nombre para la hoja.
MiNombre = InputBox("Nombre de la hoja", _
"PREVISIÓN VISITAS: Indicar comercial, PV y semana nº ")

If MiNombre = "" Then
MsgBox "Se ha cancelado la operacion. Nombre en blanco"

Exit Sub
'Else: MsgBox "EL NOMBRE DE LA HOJA ES " & MiNombre
End If

'comprobamos si el nombre contiene caracteres invalidos.
NombreValido = True
For i = 0 To UBound(carInvalidos)
If InStr(MiNombre, carInvalidos(i)) Then
MsgBox "El nombre " & MiNombre _
& " contiene caracteres invalidos (" _
& carInvalidos(i) & ")."
NombreValido = False
MsgBox "Se ha cancelado la operacion. Carácter inválido"
Exit Sub

Else: On Error Resume Next
End If
Next i

'Asignamos el nombre valido a la hoja.
If NombreValido = True Then _
NombreValido = MiNombre

'MsgBox "El nombre para archivar es: " & MiNombre


'Crea la variable de la hoja a copiar.
Set MiHoja = ThisWorkbook.Sheets("Reporte")
Pass = "19866381Q"
Application.ScreenUpdating = False
MiHoja.Unprotect Pass 'Desprotege
'Convierte formulas en valores, elimina las
'columnas innecesarias y activa la celda A3.
With MiHoja
.Activate
.Cells.Copy

.Cells.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
.Columns("I:IV").Clear
.Range("A3").Select
End With

'Elimina la hojas innecesarias.
Application.DisplayAlerts = False
For Each s In ThisWorkbook.Sheets
If s.Name <> MiHoja.Name Then s.Delete

Next s
Application.DisplayAlerts = True
'Borra los dibujos
'Borra botones y figuras excepto celdas de tilde y Picture1
ActiveSheet.Shapes("Button 7").Select
Selection.Delete
ActiveSheet.Shapes("Button 8").Select
Selection.Delete
ActiveSheet.Shapes("Button 9").Select
Selection.Delete
ActiveSheet.Shapes("Button 14").Select

Selection.Delete
Range("E1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
'Borra las macros
'Application.SendKeys
"%{f11}^r%hp^{pgdn}{+}{tab}jrfl0{tab}AquiTuPassWoRd~%q"

Set Modulos = ActiveWorkbook.VBProject.VBComponents
For Each Modulo In Modulos
Select Case Modulo.Type
Case VBExt_ct_StdModule, VBExt_ct_MSForm, _
VBExt_ct_ClassModule
Modulos.Remove Modulo
Case Else
With Modulo.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
Set Modulos = Nothing


MiHoja.Name = MiNombre 'Cambia el nombre de la hoja al q se ha eligido.
'Pide al usuario q eliga el directorio para guardar el libro.
msje = "Seleccione el directorio para la copia."
MiDirectorio = GetDirectory(msje)

'Si se ha eligido un directorio guarda el libro ahi.
If MiDirectorio <> "" Then
ThisWorkbook.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & MiDirectorio
'Si no, se guarda el libro en el director del libro original.
Else
ThisWorkbook.SaveAs ThisWorkbook.path & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If

Application.ScreenUpdating = True



End Sub
'--Fin Codigo





"Héctor Miguel" escribió en el mensaje
news:%

hola, José Rafael !

... necesitaria... una rutina completa de borrado de modulos para
incluirla en el codigo que tengo
con el que "extraigo" una copia de una hoja de un libro pero que no queda
plana sino que
se queda con una copia de todos los modulos del libro y por eso necesito
borrarlos para archivar dicha copia.

1) como es el codigo con el que "extraes" una COPIA de una hoja de un
libro ?
2) cuales son "todos los modulos del libro" con los que dicha COPIA (de
una hoja) "se queda" ?

(en teroria:) si solo copias una hoja (de un libro a otro) y ese hoja
tiene codigo en "su modulo"...
solo necesitas eliminar/borrar/... el codigo de esa hoja EN EL LIBRO a
donde la has copiado (?)

saludos,
hector.

hola, José Rafael !

Te paso todo el codigo para hacer una copia de una hoja de un libro y guardarla en el directorio que elija.

OJO: el codigo que expones NO hace una copia de una hoja de un libro a otro, lo que hace es...
- "prepara" un libro existente para ELIMINAR las hojas "sobrantes" y hacerle un "guradar como..."
- aun eliminadas las hojas sobrantes, elimina los modulos de codigo y el codigo en los modulos "de clase"

aunque esta parte ya la debes conocer (la transcribo de consultas anteriores solo por si las dudas)
Requiere: establecer una referencia (en vba) a la libreria (Microsoft Visual Basic for Applications Extensibility)
Pros: confiable ???
Cons: la version (numero) de la libreria depende de la version (de excel) donde se ha de utilizar (p.e.)
1) en excel 97 => NO DEBE tener numero de version.
2) en excel 2K => debiera funcionar sin problemas
3) en excel XP => REQUIERE (ademas) de un ajuste (en caso de no tenerlo ya) a las fuentes de confianza
este ajuste es desde (menu:) herramientas / macros / seguridad / (ficha) fuentes de confianza y ...
poner una marca en: confiar en el acceso a proyectos de visual basic

y ya "entrando en materia"... en tu procedimiento: => Sub archivarhojareporteenmisdocumentos(), tienes (para mi gusto):
- demasiadas lineas/variables/instrucciones/... que no son (absolutamente) necesarias
- algunas variables para OutLook que no se utilizan (no se que haga el procedimiento al que llamas en el otro libro ???)
- tampoco se aprecia el "por que" debes borrar TODAS las columnas "sobrantes" (I:IV) -???-
- y no me queda muy claro que pasa cuando hay errores o cancelaciones al definir "MiNombre" y "MiDirectorio" -???-

y como no me gusta "pedalear sobre bicicletas ajenas", te paso algunos "tips" acerca del como lo haria yo (?)
si cualquier duda (o informacion adicional)... comentas ?
saludos,
hector.

' la siguiente instruccion copia la hoja "reporte" como libro nuevo (aun sin nombre) _
de una sola hoja y se quedan como la hoja activa del libro activo
ThisWorkbook.Worksheets("reporte").Copy

' ahora, podemos trabajas con la hoja activa (reporte) del libro activo (aun sin nombre)
With ActiveSheet
' desprotegemos la hoja '
.Unprotect "19866381Q"
' eliminamos los botones indicados '
.Shapes.Range(Array("button 7", "button 8", "button 9", "button 14")).Delete
' borramos las columnas de tu codigo original '
.Coumns("i:iv").Clear: Debug.Print .UsedRange.Address
' convertimos formulas a valores '
.UsedRange.Value = .UsedRange.Value
' aplicamos la formula =hoy() '
.Range("e1").Formula = "=today()"
' asignamos a la hoja el nombre '
.Name = MiNombre
End With

' y aqui seguimos trabajando sobre el libro activo (aun sin nombre)
With ActiveWorkbook
' eliminamos las lineas de codigo de "su modulo de clase" '
With .VBProject.VBComponents(ActiveSheet.Name).CodeModule
.DeleteLines 1, .CountOfLines
End With
' y guardamos el libro en "MiDirectorio" con "MiNombre" '
.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
End With

__ el codigo expuesto __

'--Inicio Codigo
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'Declaraciones 32-bit API
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'Esta funcion muestra el dialogo para eligir directorio.
'Publicada por John Walkenbach.
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Directorio de raiz = Escritorio
bInfo.pidlRoot = 0&
' titulo en el dialogo
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' tipo de directorio a devolver
bInfo.ulFlags = &H1
' mostrar el dialogo
x = SHBrowseForFolder(bInfo)
' extraer el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub archivarhojareporteenmisdocumentos()
'archiva la hoja de reporte en carpeta de Mis documentos
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet
Dim Pass As String
Dim Modulo As VBIDE.VBComponent, _
Modulos As VBIDE.VBComponents
Dim carInvalidos As Variant
Dim MiArchivo As String '***********************
Dim Insout As New Outlook.Application ' Variable objeto Outlook
Dim Mimail As Outlook.MailItem ' Variable objeto mensaje Outlook
Set Mimail = Insout.CreateItem(olMailItem) ' se asigna un nuevo mensaje a la variable objeto Outlook
Dim i As Integer
Dim NombreUnico As Boolean
Dim NombreValido As Boolean
Application.Run _
"'Programa de reportes y visitas para 2.009.xls'!informesemanal"
'Guarda el libro original para no perder
'los cambios accidentalmente.
ThisWorkbook.Save
'Establecemos la lista de caracteres invalidos.
carInvalidos = Array(":", "\", "/", "?", "*", "[", "]")
'Pedimos al usuario q eliga el nombre para la hoja.
MiNombre = InputBox("Nombre de la hoja", _
"PREVISIÓN VISITAS: Indicar comercial, PV y semana nº ")
If MiNombre = "" Then
MsgBox "Se ha cancelado la operacion. Nombre en blanco"
Exit Sub
'Else: MsgBox "EL NOMBRE DE LA HOJA ES " & MiNombre
End If
'comprobamos si el nombre contiene caracteres invalidos.
NombreValido = True
For i = 0 To UBound(carInvalidos)
If InStr(MiNombre, carInvalidos(i)) Then
MsgBox "El nombre " & MiNombre _
& " contiene caracteres invalidos (" _
& carInvalidos(i) & ")."
NombreValido = False
MsgBox "Se ha cancelado la operacion. Carácter inválido"
Exit Sub
Else: On Error Resume Next
End If
Next i
'Asignamos el nombre valido a la hoja.
If NombreValido = True Then _
NombreValido = MiNombre
'MsgBox "El nombre para archivar es: " & MiNombre
'Crea la variable de la hoja a copiar.
Set MiHoja = ThisWorkbook.Sheets("Reporte")
Pass = "19866381Q"
Application.ScreenUpdating = False
MiHoja.Unprotect Pass 'Desprotege
'Convierte formulas en valores, elimina las
'columnas innecesarias y activa la celda A3.
With MiHoja
.Activate
.Cells.Copy
.Cells.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
.Columns("I:IV").Clear
.Range("A3").Select
End With
'Elimina la hojas innecesarias.
Application.DisplayAlerts = False
For Each s In ThisWorkbook.Sheets
If s.Name <> MiHoja.Name Then s.Delete
Next s
Application.DisplayAlerts = True
'Borra los dibujos
'Borra botones y figuras excepto celdas de tilde y Picture1
ActiveSheet.Shapes("Button 7").Select
Selection.Delete
ActiveSheet.Shapes("Button 8").Select
Selection.Delete
ActiveSheet.Shapes("Button 9").Select
Selection.Delete
ActiveSheet.Shapes("Button 14").Select

Selection.Delete
Range("E1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
'Borra las macros
'Application.SendKeys "%{f11}^r%hp^{pgdn}{+}{tab}jrfl0{tab}AquiTuPassWoRd~%q"
Set Modulos = ActiveWorkbook.VBProject.VBComponents
For Each Modulo In Modulos
Select Case Modulo.Type
Case VBExt_ct_StdModule, VBExt_ct_MSForm, _
VBExt_ct_ClassModule
Modulos.Remove Modulo
Case Else
With Modulo.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
Set Modulos = Nothing
MiHoja.Name = MiNombre 'Cambia el nombre de la hoja al q se ha eligido.
'Pide al usuario q eliga el directorio para guardar el libro.
msje = "Seleccione el directorio para la copia."
MiDirectorio = GetDirectory(msje)
'Si se ha eligido un directorio guarda el libro ahi.
If MiDirectorio <> "" Then
ThisWorkbook.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & MiDirectorio
'Si no, se guarda el libro en el director del libro original.
Else
ThisWorkbook.SaveAs ThisWorkbook.path & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If
Application.ScreenUpdating = True
End Sub
'--Fin Codigo

Hola Héctor:
He hecho las rectificaciones pertinentes según tus "tips" que han sido muy
valiosos para el objetivo final.
No obstante, a pesar de que funciona, en la parte de guardar hay algo que
corregir porque me ha guardado bien en una ocasión pero si cancelo ... me
guarda todo el libro con el nombre que le digo pero ademas crea un libro
nuevo nº nn que nos se guarda francamente no sé donde está el error
(quizas los if..else).
En cuanto a lo de:

aunque esta parte ya la debes conocer (la transcribo de consultas
anteriores solo por si las dudas)
Requiere: establecer una referencia (en vba) a la libreria (Microsoft
Visual Basic for Applications Extensibility)

me suena a "chino" y no me acuerdo de nada

Bueno gracias por todo como siempre por tu inestimable ayuda y ahora
transcribo el código tal y como ha quedado...
Saludos
José Rafael-Valencia (España)

CODIGO ACTUAL QUE FUNCIONA CASI BIEN...(salvo el comentario de arriba)
-
Sub archivarhojareporte()
'archiva la hoja de reporte modificado por consejos de Héctor el 23-08-09
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet
Dim Pass As String
Dim Modulo As VBIDE.VBComponent, _
Modulos As VBIDE.VBComponents
Dim carInvalidos As Variant

Dim MiArchivo As String
'***********************
Dim Insout As New Outlook.Application ' Variable objeto
Outlook
Dim Mimail As Outlook.MailItem ' Variable objeto
mensaje Outlook
Set Mimail = Insout.CreateItem(olMailItem) ' se asigna un nuevo
mensaje a la variable objeto Outlook
Dim i As Integer
Dim NombreUnico As Boolean
Dim NombreValido As Boolean
Application.ScreenUpdating = False
'Establecemos la lista de caracteres invalidos.
carInvalidos = Array(":", "\", "/", "?", "*", "[", "]")

'Pedimos al usuario q eliga el nombre para la hoja.
MiNombre = InputBox("Nombre de la hoja", _
"REPORTE: Indicar comercial, RV y semana nº ")

If MiNombre = "" Then
MsgBox "Se ha cancelado la operacion. Nombre en blanco"

Exit Sub
'Else: MsgBox "EL NOMBRE DE LA HOJA ES " & MiNombre
End If

'comprobamos si el nombre contiene caracteres invalidos.
NombreValido = True
For i = 0 To UBound(carInvalidos)
If InStr(MiNombre, carInvalidos(i)) Then
MsgBox "El nombre " & MiNombre _
& " contiene caracteres invalidos (" _
& carInvalidos(i) & ")."
NombreValido = False
MsgBox "Se ha cancelado la operacion. Carácter inválido"
Exit Sub

Else: On Error Resume Next
End If
Next i

'Asignamos el nombre valido a la hoja.
If NombreValido = True Then _
NombreValido = MiNombre

MsgBox "El nombre para archivar es: " & MiNombre


'Crea la variable de la hoja a copiar.
ThisWorkbook.Worksheets("Reporte").Copy
With ActiveSheet
.Unprotect "jrfl0"
'ELIMINAMOS LOS BOTONES
.Shapes.Range(Array("button 1", "button 2", "button 3", "button
4")).Delete
'BORRAMOS LAS COLUMNAS innecesarias
.Columns("i:iv").Clear: Debug.Print .UsedRange.Adress
'.Range("A3").Select
'Convierte formulas en valores, elimina las
.UsedRange.Value = .UsedRange.Value
'aplicamos la formula hoy()
.Range("E1").Formula = "=TODAY()"
'asignamos la hoja el nombre
.Name = MiNombre
End With
'Borra las macros
With ActiveWorkbook
' eliminamos las lineas de codigo de "su modulo de clase"'
With .VBProject.VBComponents(ActiveSheet.Name).CodeModule
.DeleteLines 1, .CountOfLines
End With
'Selecciona directorio
msje = "Seleccione el directorio para la copia."
MiDirectorio = GetDirectory(msje)

'Si se ha eligido un directorio guarda el libro ahi.
If MiDirectorio <> "" Then
.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & MiDirectorio
'Si no, se guarda el libro en el directorio del libro original
Else
.SaveAs ThisWorkbook.path & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If
End With
Application.ScreenUpdating = True



End Sub
'--Fin Codigo
"Héctor Miguel" escribió en el mensaje
news:O$

hola, José Rafael !

Te paso todo el codigo para hacer una copia de una hoja de un libro y
guardarla en el directorio que elija.

OJO: el codigo que expones NO hace una copia de una hoja de un libro a
otro, lo que hace es...
- "prepara" un libro existente para ELIMINAR las hojas "sobrantes" y
hacerle un "guradar como..."
- aun eliminadas las hojas sobrantes, elimina los modulos de codigo y el
codigo en los modulos "de clase"

aunque esta parte ya la debes conocer (la transcribo de consultas
anteriores solo por si las dudas)
Requiere: establecer una referencia (en vba) a la libreria (Microsoft
Visual Basic for Applications Extensibility)
Pros: confiable ???
Cons: la version (numero) de la libreria depende de la version (de
excel) donde se ha de utilizar (p.e.)
1) en excel 97 => NO DEBE tener numero de version.
2) en excel 2K => debiera funcionar sin problemas
3) en excel XP => REQUIERE (ademas) de un ajuste (en caso
de no tenerlo ya) a las fuentes de confianza
este ajuste es desde (menu:) herramientas / macros /
seguridad / (ficha) fuentes de confianza y ...
poner una marca en: confiar en el acceso a proyectos de
visual basic

y ya "entrando en materia"... en tu procedimiento: => Sub
archivarhojareporteenmisdocumentos(), tienes (para mi gusto):
- demasiadas lineas/variables/instrucciones/... que no son (absolutamente)
necesarias
- algunas variables para OutLook que no se utilizan (no se que haga el
procedimiento al que llamas en el otro libro ???)
- tampoco se aprecia el "por que" debes borrar TODAS las columnas
"sobrantes" (I:IV) -???-
- y no me queda muy claro que pasa cuando hay errores o cancelaciones al
definir "MiNombre" y "MiDirectorio" -???-

y como no me gusta "pedalear sobre bicicletas ajenas", te paso algunos
"tips" acerca del como lo haria yo (?)
si cualquier duda (o informacion adicional)... comentas ?
saludos,
hector.

' la siguiente instruccion copia la hoja "reporte" como libro nuevo (aun
sin nombre) _
de una sola hoja y se quedan como la hoja activa del libro activo
ThisWorkbook.Worksheets("reporte").Copy

' ahora, podemos trabajas con la hoja activa (reporte) del libro activo
(aun sin nombre)
With ActiveSheet
' desprotegemos la hoja '
.Unprotect "19866381Q"
' eliminamos los botones indicados '
.Shapes.Range(Array("button 7", "button 8", "button 9", "button
14")).Delete
' borramos las columnas de tu codigo original '
.Coumns("i:iv").Clear: Debug.Print .UsedRange.Address
' convertimos formulas a valores '
.UsedRange.Value = .UsedRange.Value
' aplicamos la formula =hoy() '
.Range("e1").Formula = "=today()"
' asignamos a la hoja el nombre '
.Name = MiNombre
End With

' y aqui seguimos trabajando sobre el libro activo (aun sin nombre)
With ActiveWorkbook
' eliminamos las lineas de codigo de "su modulo de clase" '
With .VBProject.VBComponents(ActiveSheet.Name).CodeModule
.DeleteLines 1, .CountOfLines
End With
' y guardamos el libro en "MiDirectorio" con "MiNombre" '
.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
End With

__ el codigo expuesto __

'--Inicio Codigo
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'Declaraciones 32-bit API
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'Esta funcion muestra el dialogo para eligir directorio.
'Publicada por John Walkenbach.
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Directorio de raiz = Escritorio
bInfo.pidlRoot = 0&
' titulo en el dialogo
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' tipo de directorio a devolver
bInfo.ulFlags = &H1
' mostrar el dialogo
x = SHBrowseForFolder(bInfo)
' extraer el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub archivarhojareporteenmisdocumentos()
'archiva la hoja de reporte en carpeta de Mis documentos
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet
Dim Pass As String
Dim Modulo As VBIDE.VBComponent, _
Modulos As VBIDE.VBComponents
Dim carInvalidos As Variant
Dim MiArchivo As String '***********************
Dim Insout As New Outlook.Application ' Variable objeto
Outlook
Dim Mimail As Outlook.MailItem ' Variable objeto
mensaje Outlook
Set Mimail = Insout.CreateItem(olMailItem) ' se asigna un nuevo
mensaje a la variable objeto Outlook
Dim i As Integer
Dim NombreUnico As Boolean
Dim NombreValido As Boolean
Application.Run _
"'Programa de reportes y visitas para 2.009.xls'!informesemanal"
'Guarda el libro original para no perder
'los cambios accidentalmente.
ThisWorkbook.Save
'Establecemos la lista de caracteres invalidos.
carInvalidos = Array(":", "\", "/", "?", "*", "[", "]")
'Pedimos al usuario q eliga el nombre para la hoja.
MiNombre = InputBox("Nombre de la hoja", _
"PREVISIÓN VISITAS: Indicar comercial, PV y semana nº ")
If MiNombre = "" Then
MsgBox "Se ha cancelado la operacion. Nombre en blanco"
Exit Sub
'Else: MsgBox "EL NOMBRE DE LA HOJA ES " & MiNombre
End If
'comprobamos si el nombre contiene caracteres invalidos.
NombreValido = True
For i = 0 To UBound(carInvalidos)
If InStr(MiNombre, carInvalidos(i)) Then
MsgBox "El nombre " & MiNombre _
& " contiene caracteres invalidos (" _
& carInvalidos(i) & ")."
NombreValido = False
MsgBox "Se ha cancelado la operacion. Carácter inválido"
Exit Sub
Else: On Error Resume Next
End If
Next i
'Asignamos el nombre valido a la hoja.
If NombreValido = True Then _
NombreValido = MiNombre
'MsgBox "El nombre para archivar es: " & MiNombre
'Crea la variable de la hoja a copiar.
Set MiHoja = ThisWorkbook.Sheets("Reporte")
Pass = "19866381Q"
Application.ScreenUpdating = False
MiHoja.Unprotect Pass 'Desprotege
'Convierte formulas en valores, elimina las
'columnas innecesarias y activa la celda A3.
With MiHoja
.Activate
.Cells.Copy
.Cells.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
.Columns("I:IV").Clear
.Range("A3").Select
End With
'Elimina la hojas innecesarias.
Application.DisplayAlerts = False
For Each s In ThisWorkbook.Sheets
If s.Name <> MiHoja.Name Then s.Delete
Next s
Application.DisplayAlerts = True
'Borra los dibujos
'Borra botones y figuras excepto celdas de tilde y Picture1
ActiveSheet.Shapes("Button 7").Select
Selection.Delete
ActiveSheet.Shapes("Button 8").Select
Selection.Delete
ActiveSheet.Shapes("Button 9").Select
Selection.Delete
ActiveSheet.Shapes("Button 14").Select

Selection.Delete
Range("E1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
'Borra las macros
'Application.SendKeys
"%{f11}^r%hp^{pgdn}{+}{tab}jrfl0{tab}AquiTuPassWoRd~%q"
Set Modulos = ActiveWorkbook.VBProject.VBComponents
For Each Modulo In Modulos
Select Case Modulo.Type
Case VBExt_ct_StdModule, VBExt_ct_MSForm, _
VBExt_ct_ClassModule
Modulos.Remove Modulo
Case Else
With Modulo.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
Set Modulos = Nothing
MiHoja.Name = MiNombre 'Cambia el nombre de la hoja al q se ha eligido.
'Pide al usuario q eliga el directorio para guardar el libro.
msje = "Seleccione el directorio para la copia."
MiDirectorio = GetDirectory(msje)
'Si se ha eligido un directorio guarda el libro ahi.
If MiDirectorio <> "" Then
ThisWorkbook.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & MiDirectorio
'Si no, se guarda el libro en el director del libro original.
Else
ThisWorkbook.SaveAs ThisWorkbook.path & "\" & MiNombre & ".xls"
MiArchivo = ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If
Application.ScreenUpdating = True
End Sub
'--Fin Codigo

hola, José Rafael !

... a pesar de que funciona, en la parte de guardar hay algo que corregir porque me ha guardado bien en una ocasion
pero si cancelo... me guarda todo el libro con el nombre que le digo pero ademas crea un libro nuevo nº nn que nos se guarda
... francamente no se donde esta el error (quizas los if..else)...

en la fraccion y arreglo de codigo que expones, no "se aprecia" alguna instruccion que pudiera crear otro libro que no se cierra (?)
(no tienes aun en alguna parte de tus procesos alguna llamada a una macro en otro libro como tenias originalmente ???)

haciendo pruebas con el "GetDirectory(..." tampoco encontre fallas si el usuario cancela el dialogo para seleccionar carpeta/s
por lo que el if...else...end if creo que no son causa del comportamiento que describes (?)

(creo que...) "te toca" hacer una investigacion mas a fondo con (todos ?) los procedimientos que utilizas (?)

saludos,
hector.