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