Ayuda con código p.f.

Hola colega,

Prueba el codigo de abajo q se tiene q copiar a un modulo normal (q no sea
de hoja, libro, formulario - vamos - de clase). Pega este codigo a partir de
la primera linea del modulo, ya q las declaraciones q incluye deben estar
arriba del todo en un modulo.

Saludos,
KL

'--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 archivarhojaprevisionessemanalenmisdocumentos()
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet

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

'Crea la variable de la hoja a copiar.
Set MiHoja = ThisWorkbook.Sheets("PrevisiNn")

Application.ScreenUpdating = False

'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

'Pide al usuario q eliga el nombre para el libro.
MiNombre = InputBox("Nombre de la hoja", _
"Indicar Semana y sin espacio el n?")

'Cambia el nombre de la hoja al q se ha eligido.
MiHoja.Name = MiNombre

'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"
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"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If

Application.ScreenUpdating = True
End Sub
'--Fin Codigo


"Aprendiz" wrote in message
news:

Saludos . Necesito completar este código y no sé como hacerlo. Agradeceré
cualquier ayuda. Gracias.

José Rafael - Valencia (España)
pepefrasALGARROBAarrakis.es
(ALGARROBA=@)

Este es el código para crear una hoja por cada semana de previsión de
visitas (actualmente estoy grabando un libro)
¿se podría almacenar las hojas semanales en un libro p.ej. "Enero 2.005" y
sucesivos meses?. Gracias

Sub archivarhojaprevisionessemanalenmisdocumentos()
'
' archivarhojaprevisionessemanalenmisdocumentos Macro
' Macro grabada el 26/01/2005 por jrfl
'
Dim previsionsemanal As Variant
Dim discoduro As Variant
Application.ScreenUpdating = False
Sheets("Previsión").Select
'Selecciono toda la hoja
Cells.Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:> _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:> _
False, Transpose:=False
'Borro el resto de columnas de la hoja
Columns("I:IV").Select
Application.CutCopyMode = False
Selection.Clear
'Aqui poner el código para imprimir en dun DIN A4
'ActiveWindow.SelectedSheets.PrintPreview?
'ActiveWindow.View = xlPageBreakPreview?

'ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight,
RegionIndex:=1?

'ActiveSheet.HPageBreaks(1).DragOff Direction:=xlDown, RegionIndex:=1?
'ActiveWindow.View = xlNormalView?

previsionsemanal = InputBox("Nombre de la hoja", "Indicar Semana y sin
espacio el nº")
Sheets("Hoja1").Select
Sheets("Hoja1").Name = previsionsemanal
'Ahora eliminar el resto de hojas abiertas del libro ¿como es?
discoduro = InputBox("Disco duro", "Indicar letra para Mis documentos")
'como se hace para que sea mayusculas siempre?
'Como se hace para que me ponga la letra? Mejor aún, ¿se puede abrir el
cuadro de directorio para elefirlo?

ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\José
Rafael\Mis documentos\Previsiones de visita 2.005\" & previsionsemanal,
FileFormat _
:=xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:= _
False, CreateBackup:=False
Sheets("Previsión").Select
Range("A3").Select
Application.ScreenUpdating = True
End Sub

Gracias KL todo funciona como estaba previsto solo que .me faltará una
linea de código? para borrar todos los botones de macros que tiene la
hoja.
Si eres tan amable me la incluyes?, o hay otra solución ...
Gracias por todo
José Rafael

"KL" escribió en el mensaje
news:

Hola colega,

Prueba el codigo de abajo q se tiene q copiar a un modulo normal (q no sea
de hoja, libro, formulario - vamos - de clase). Pega este codigo a partir

de

la primera linea del modulo, ya q las declaraciones q incluye deben estar
arriba del todo en un modulo.

Saludos,
KL

'--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 archivarhojaprevisionessemanalenmisdocumentos()
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet

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

'Crea la variable de la hoja a copiar.
Set MiHoja = ThisWorkbook.Sheets("PrevisiNn")

Application.ScreenUpdating = False

'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

'Pide al usuario q eliga el nombre para el libro.
MiNombre = InputBox("Nombre de la hoja", _
"Indicar Semana y sin espacio el n?")

'Cambia el nombre de la hoja al q se ha eligido.
MiHoja.Name = MiNombre

'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"
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"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If

Application.ScreenUpdating = True
End Sub
'--Fin Codigo


"Aprendiz" wrote in message
news:
> Saludos . Necesito completar este código y no sé como hacerlo.

Agradeceré

> cualquier ayuda. Gracias.
>
> José Rafael - Valencia (España)
> pepefrasALGARROBAarrakis.es
> (ALGARROBA=@)
>
> Este es el código para crear una hoja por cada semana de previsión de
> visitas (actualmente estoy grabando un libro)
> ¿se podría almacenar las hojas semanales en un libro p.ej. "Enero 2.005"

y

> sucesivos meses?. Gracias
>
> Sub archivarhojaprevisionessemanalenmisdocumentos()
> '
> ' archivarhojaprevisionessemanalenmisdocumentos Macro
> ' Macro grabada el 26/01/2005 por jrfl
> '
> Dim previsionsemanal As Variant
> Dim discoduro As Variant
> Application.ScreenUpdating = False
> Sheets("Previsión").Select
> 'Selecciono toda la hoja
> Cells.Select
> Selection.Copy
> Workbooks.Add
> Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
> SkipBlanks:> > _
> False, Transpose:=False
> Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,

SkipBlanks:> > _

> False, Transpose:=False
> 'Borro el resto de columnas de la hoja
> Columns("I:IV").Select
> Application.CutCopyMode = False
> Selection.Clear
> 'Aqui poner el código para imprimir en dun DIN A4
> 'ActiveWindow.SelectedSheets.PrintPreview?
> 'ActiveWindow.View = xlPageBreakPreview?
>
> 'ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight,
> RegionIndex:=1?
>
> 'ActiveSheet.HPageBreaks(1).DragOff Direction:=xlDown,

RegionIndex:=1?

> 'ActiveWindow.View = xlNormalView?
>
> previsionsemanal = InputBox("Nombre de la hoja", "Indicar Semana y

sin

> espacio el nº")
> Sheets("Hoja1").Select
> Sheets("Hoja1").Name = previsionsemanal
> 'Ahora eliminar el resto de hojas abiertas del libro ¿como es?
> discoduro = InputBox("Disco duro", "Indicar letra para Mis

documentos")

> 'como se hace para que sea mayusculas siempre?
> 'Como se hace para que me ponga la letra? Mejor aún, ¿se puede abrir

el

> cuadro de directorio para elefirlo?
>
> ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\José
> Rafael\Mis documentos\Previsiones de visita 2.005\" & previsionsemanal,
> FileFormat _
> :=xlNormal, Password:="", WriteResPassword:="",
> ReadOnlyRecommended:= _
> False, CreateBackup:=False
> Sheets("Previsión").Select
> Range("A3").Select
> Application.ScreenUpdating = True
> End Sub
>
>
>
>

Hola Aprendiz,

"Aprendiz" wrote in message...

.me faltará una linea de código? para borrar
todos los botones de macros que tiene la hoja.

?De q tipo son los botones, ActiveX o de Formularios? ?O tal vez de ambos?

Saludos,
KL

Son de formulario
"KL" escribió en el mensaje
news:

Hola Aprendiz,

"Aprendiz" wrote in message...

.me faltará una linea de código? para borrar
todos los botones de macros que tiene la hoja.

?De q tipo son los botones, ActiveX o de Formularios? ?O tal vez de ambos?

Saludos,
KL

Hola Aprendiz,

Pues entonces prueba el codigo de abajo. Por si acaso le he anadido estas
lineas:

Dim OLEobj As Excel.OLEObject

'Elimina botones de formulario.
.Buttons.Delete

'Elimina todos los objetos OLE.
For Each OLEobj In .OLEObjects
OLEobj.Delete
Next OLEobj

Saludos,
KL

'--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 archivarhojaprevisionessemanalenmisdocumentos()
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet
Dim OLEobj As Excel.OLEObject

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

'Crea la variable de la hoja a copiar.
Set MiHoja = ThisWorkbook.Sheets("PrevisiNn")

Application.ScreenUpdating = False

'Convierte formulas en valores, elimina las
'columnas innecesarias y activa la celda A3.
With MiHoja
.Activate
'Elimina botones de formulario.
.Buttons.Delete
'Elimina todos los objetos OLE.
For Each OLEobj In .OLEObjects
OLEobj.Delete
Next OLEobj
.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

'Pide al usuario q eliga el nombre para el libro.
MiNombre = InputBox("Nombre de la hoja", _
"Indicar Semana y sin espacio el n?")

'Cambia el nombre de la hoja al q se ha eligido.
MiHoja.Name = MiNombre

'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"
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"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If

Application.ScreenUpdating = True
End Sub
'--Fin Codigo

"José Frasquet" wrote in message
news:

Son de formulario
"KL" escribió en el mensaje
news:

Hola Aprendiz,

"Aprendiz" wrote in message...

.me faltará una linea de código? para borrar
todos los botones de macros que tiene la hoja.

?De q tipo son los botones, ActiveX o de Formularios? ?O tal vez de
ambos?

Saludos,
KL