Jump to content

[SOLUCIONADO] crear archivo nuevo a partir de una hoja de otro libro


Recommended Posts

Hola a todos;

aqui estoy de nuevo, porque llevo unos dias calentandome la cabeza y no hay manera.

Tengo un archivo con muchas hojas, en el archivo un botón con una macro. La macro lo que hace es mostrarme el nombre de todas las hojas en una lista. Cuando pincho en una hoja se va a esa hoja. Bien, mi pregunta es, como podría hacer que cuando pinchara en la lista en una hoja ,se creara un libro aparte que tanto la hoja como el libro tuvieran el nombre de la hoja que haya pulsado.

Por ejemplo, en la lista pulso la hoja con nombre ENERO, y al pinchar que se creara un archivo llamado enero.xls y que dentro tuviera una copia exacta de la hoja ENERO.

Un Saludo.

Jose Maria.

listar hojas.zip

Link to post
Share on other sites

Hola de nuevo;

estoy dandole vueltas. Con la siguiente macro, lo que hago es que directamente me haga una copia de cada una de las hojas que hay en el libro, pero no se como unificar ambas macros .

Sub Crear_archivos_de_hojas()

Dim strHoja, strStartHoja, strRuta As String

Dim i As Integer

Application.ScreenUpdating = False

strStartHoja = ActiveCell.Worksheet.Name

'bucle todas hojas

For i = 1 To Sheets.Count

'copia la hoja a libro nuevo

Sheets(i).Activate

strHoja = ActiveCell.Worksheet.Name

Sheets(strHoja).Copy

'donde guardar los archivos creados

strRuta = "C:\excel"

'guarda el libro nuevo

ActiveWorkbook.SaveAs Filename:=strRuta & "\" & strHoja, _

FileFormat:=xlNormal, Password:="", WriteResPassword:="", _

ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWindow.Close Savechanges:=True

'repetir bucle'

Next

Sheets(strStartHoja).Activate

Application.ScreenUpdating = True

End Sub

Un saludo

Jose Maria.

Link to post
Share on other sites

Hola logroastur;

sorprendente , jejje es exactamente lo que buscaba, muchas gracias.

Pero una cosa, cuando le doy a crear hoja y me dice que existe que si quiero reemplazarla, tengo dos opciones si, o no.

si pincho en si, se reeemplaza sin ningun problema si le digo que no, me salta un error de visual basic. Se podría hacer que no saliera ese error?

y estoy dandole vueltas, y haciendo pruebas, pero, no consigo ponerlo en un modulo, sin que tenga formulario. Asi sin tener formulario creo un boton en la barra de herramientas y lo tengo cuando habra cualquier excel.

Con el formulario , si quiero pasar eso a otra hoja tengo que copiar el modulo y el formulario a la hoja nueva.

¿o?, lo has echo con formulario porque no se puede hacer de la otra forma, y yo aqui dandole vueltas a algo que no se puede.

Link to post
Share on other sites

Hola a todos;

Ante todo, es un lujo compartir un post contigo, creo que nunca habiamos coincidido.

Por otro lado , gracias por esa linea de codigo, funciona a la perfeción.

La aplicación que has subido es fantastica, voy a verla mas detenidamente.

Lo que yo pretendo hacer es algo mas sencillo. Hacer lo que exactamente hace logroastur con su ejemplo,(perfecto), pero mas sencillo aun, sin formulario.

que cuando yo le de al boton, como en mi ejemplo, me salga una lista con las hojas que tiene el libro y que haga lo mismo que hace el ejemplo de logroastur, cree un nuevo libro con el nombre de la hoja. Pero no lo consigo.

Un Saludo.

Jose Maria.

Link to post
Share on other sites

Hola;

ya estoy aqui de nuevo.

Estoy intentando meter el codigo que me ha facilitado logroastur, para que cuando pinche, por que ejmplo en un boton, me cree en libro, pero no incrustar , este codigo:

Private Sub ListBox1_Click()

Dim folia, strRuta, strHoja

folia = ListBox1

strHoja = folia & ".xls"

Sheets(folia).Copy

strRuta = "C:\excel\" & strHoja

'guarda el libro nuevo

Workbooks(2).SaveAs Filename:=strRuta, FileFormat:=xlNormal

Workbooks(2).Close Savechanges:=True

MsgBox "Libro " & folia & " creado satisfactoriamente", , ""

Unload Listar_Hojas

End Sub

en este otro:

Sub ListaHojas(): On Error GoTo DoNothing

Debug.Print ActiveSheet.Type

With Application.CommandBars("workbook tabs").Controls(16)

'If Right(.Caption, 3) = "..." Then .Execute Else .Parent.ShowPopup

End With

DoNothing:

ListBox1_Click

End Sub

de tal forma que yo pincho en el boton me sale la lista desplegable con las hojas del libro y cuando le de, pues me crea el libro.

como podría ser.

Un Saludo.

José María.

Link to post
Share on other sites

Hola josemaria

Intenta con el siguiente codigo


Sub ListaHojas():
Dim HojaActual As String, strRuta As String
On Error GoTo Finalizar'
HojaActual = ActiveSheet.Name
With Application.CommandBars("workbook tabs").Controls(16)
If Right(.Caption, 3) = "..." Then .Execute Else .Parent.ShowPopup
End With
If ActiveSheet.Name <> HojaActual Then
'Ruta donde deseas guardar el archivo
strRuta = "C:\excel\"
'Verifica si esxiste el libro
If Dir(strRuta & ActiveSheet.Name & ".xls*") <> "" Then
If MsgBox("El archivo " & strRuta & Dir(strRuta & ActiveSheet.Name & ".xls*") & " ya existe" & vbNewLine _
& "¿Desea Reemplazarlo?", vbYesNo + vbQuestion) = vbYes Then
Kill strRuta & Dir(strRuta & ActiveSheet.Name & ".xls*")
Else
Exit Sub
End If
End If
ActiveSheet.Copy
'guarda el libro nuevo
ActiveWorkbook.SaveAs Filename:=strRuta & ActiveSheet.Name, FileFormat:=xlNormal
MsgBox "Libro " & strRuta & Dir(strRuta & ActiveSheet.Name & ".xls*") & " creado satisfactoriamente", vbInformation
End If
Exit Sub
Finalizar:
MsgBox "Ocurrio el siguiente error:" & vbNewLine & _
"Número de error " & Err.Number & " Descripción: " & Err.Description, vbCritical
End Sub[/CODE]

No me queda claro si deseas que te quede activo el libro creado o regrese al libro donde esta la macro, nos comentas por favor para asi adecuarla, saludos

Link to post
Share on other sites

Hola;

mil gracias neverdelimon1, no veas que peso me has quitado de encima.

Al final he dejado la macro así, si no tienes inconveniente:


Sub ListaHojas2():
Application.DisplayAlerts = False
Dim HojaActual As String, strRuta As String
On Error GoTo Finalizar '
HojaActual = ActiveSheet.Name
With Application.CommandBars("workbook tabs").Controls(16)
If Right(.Caption, 3) = "..." Then .Execute Else .Parent.ShowPopup
End With
If ActiveSheet.Name <> HojaActual Then
'Ruta donde deseas guardar el archivo
strRuta = "C:\excel\"
ActiveSheet.Copy
'guarda el libro nuevo
ActiveWorkbook.SaveAs Filename:=strRuta & ActiveSheet.Name, FileFormat:=xlNormal
MsgBox "Libro " & strRuta & Dir(strRuta & ActiveSheet.Name & ".xls*") & " creado satisfactoriamente", vbInformation
End If
Exit Sub
Finalizar:
End Sub

[/CODE]

con respecto a lo que comentas al final, si puede ser, quiero que regrese a la hoja activa, a la hoja donde estabamos, y que cierre la hoja creada.

[CODE]
Sub ListaHojas2():
Application.DisplayAlerts = False
Dim HojaActual As String, strRuta As String
On Error GoTo Finalizar '
HojaActual = ActiveSheet.Name
With Application.CommandBars("workbook tabs").Controls(16)
If Right(.Caption, 3) = "..." Then .Execute Else .Parent.ShowPopup
End With
If ActiveSheet.Name <> HojaActual Then
'Ruta donde deseas guardar el archivo
strRuta = "C:\excel\"
ActiveSheet.Copy
'guarda el libro nuevo
ActiveWorkbook.SaveAs Filename:=strRuta & ActiveSheet.Name, FileFormat:=xlNormal
MsgBox "Libro " & strRuta & Dir(strRuta & ActiveSheet.Name & ".xls*") & " creado satisfactoriamente", vbInformation
[COLOR="Red"]'cerrar hoja abierta
'volver a la hoja donde estabamos [/COLOR]
End If
Exit Sub
Finalizar:
End Sub

[/CODE]

Un Saludo.

Jose Maria.

Link to post
Share on other sites

Hola, antes que nada perdon por la intromisión, pero este post contiene algo de lo que puse en mi última consulta. Recapitulando: 1.las diversas aportaciones hechas por nuestros amigos (josemaria, logroastur, Macro Antonio y neverdelimon1) me permiti ponerlas en el archivo anexo, ¡estan excelentes!. 2. ahora mi pregunta sera qué puedo aprovechar el código expuesto por nuestro amigo neverdelimon1 en conjunto con el código expuesto en otro post por nuestro gran amigo

mjrofra Re: crear hojar de excel segun valores filtrados

Creo que esto hará el truco, si es que te estoy entendiendo bien:

Código:

Sub prueba()

Dim Color As Excel.Range

Dim Hj As Excel.Worksheet

Application.ScreenUpdating = False

With Sheets("Sheet1").Range("a1").CurrentRegion

.Columns(15).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

For Each Color In .Offset(1, 14).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)

On Error Resume Next

Set Hj = Sheets(Color.Value)

On Error GoTo 0

If Hj Is Nothing Then

Set Hj = Sheets.Add(after:=Sheets(Sheets.Count))

Hj.Name = Color

End If

.AutoFilter field:=15, Criteria1:=Color

.SpecialCells(xlCellTypeVisible).Copy Hj.Range("a1")

Set Hj = Nothing

Next Color

.AutoFilter

End With

Application.ScreenUpdating = True

End SubMauricio

Tal código lo menciono en la más reciente consulta hecha por éste su servidor y amigo para lograr lo mismo con la diferencia de que lo haga en automático sin que tenga que seleccionar la hoja desde el formulario con el listbox.

Agradeciendo de antemano su valiosa ayuda los saluda desde México.

Martín Ruiz

PD. Tambien anexo el archivo mencionado.

filtra y crea hoja ByMjrofra.zip

listar hojas ByNeverdelimon.zip

Link to post
Share on other sites
Hola Martin Ruiz

Para poder adaptar la macro del master y moderador mjrofra es necesario que por favor nos aclares algunas cuestiones.

-Dónde seria la ruta donde se guardarían los libros

-Si el libro con el nombre de la hoja a crear ya existe, se sobreescrbie este?, o se añaden los datos al final?

saludos cordiales

Master neverdelimon1

Gracias por la respuesta tan rapida a mi consulta, mira en relación a tú primer pregunta en el archivo que tiene tu aportación y que me tome la libertad de adaptar, le coloque un comando que permite me lo guarde en la misma carpeta en donde este el archivo base (Listar hojas.xls), no importa el lugar; ahora respondiendo a tu segunda pregunta con que se sobreescriba esta bien.

Y de nueva cuenta agradeciendo tu amabilidad y en espera de tu valiosa ayuda, tu servidor y amigo.

Martín Ruiz

Link to post
Share on other sites

Hola martin

Intenta asi

Sub prueba()


Dim Color As Excel.Range
Dim Hj As Excel.Worksheet


Application.ScreenUpdating = False


With Sheets("Sheet1").Range("a1").CurrentRegion

.Columns(15).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

For Each Color In .Offset(1, 14).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)

On Error Resume Next
Set Hj = Sheets(Color.Value)
On Error GoTo 0

If Hj Is Nothing Then
Set Hj = Sheets.Add(after:=Sheets(Sheets.Count))
Hj.Name = Color
Else
Hj.Cells.Clear
End If

.AutoFilter field:=15, Criteria1:=Color
.SpecialCells(xlCellTypeVisible).Copy Hj.Range("a1")
'verifica si ya existe el libro y lo borra
On Error GoTo fin
If Dir(ThisWorkbook.Path & Application.PathSeparator & Hj.Name & ".xls") <> "" Then Kill ThisWorkbook.Path & Application.PathSeparator & Dir(ThisWorkbook.Path & Application.PathSeparator & Hj.Name & ".xls")
'copia la hoja a un nuevo libro
Hj.Move
'guarda el libro
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & ActiveSheet.Name, FileFormat:=xlNormal
'cerra el libro
ActiveWorkbook.Close True
Set Hj = Nothing

Next Color

.AutoFilter

End With


Application.ScreenUpdating = True

Exit Sub
fin:
MsgBox "Ocurrio el siguiente error:" & vbNewLine & _
"Número de error " & Err.Number & " Descripción: " & Err.Description, vbCritical
End Sub[/CODE]

Saludos

Link to post
Share on other sites
Guest
This topic is now closed to further replies.


  • Posts

    • Hola @Serch! Adjunto una alternativa empleando una columna auxiliar! Saludos! Ejemplo busqueda de valor correspondiente para cada semana.xlsx
    • Hola buenos dias, solicito de su apoyo ya que necesito encontrar un valor "ID" de una "Tienda" a lo largo de 1 mes y que me de como resultado para cada semana el "ID" de la persona que fue a visitar esa tienda.   Espero me puedan ayudar, adjunto ejemplo e instrucciones dentro de este.   mil gracias y saludos.¡¡¡ Ejemplo busqueda de valor correspondiente para cada semana.xlsx
    • saludos. estoy desarrollando un formulario en los deseo calcular varios textbox y mostrar el resultado en otros, el problema radica cuando los coloco con formato de miles los cálculos no funcionan; por favor si alguien me puede dar una ayuda o indicarme el procedimiento. ya he utilizado el cdbl(replace((.. obteniendo el mismo resultado. adjunto enlace. https://drive.google.com/drive/folders/1mPjlo-c7rCrwALgK9pF20e3J-XQG8Wk6?usp=sharing muchas gracias por su pronta colaboración.
    • Bueno!!, logre hacer que funcione. Este seria el codigo final. ' Modulo NoCoincidencia Dim SerialNoAuditado As Variant On Error GoTo IngresarSerialNoAuditado: SerialNoAuditado = Worksheets("Reg. N-Auditados").Range("B5").Value Resultado = Application.WorksheetFunction.Match(SerialNoAuditado, Worksheets("Laptop").Range("D6:D40005"), 0) If Resultado > 0 Then GoTo SerialAuditado: Else GoTo IngresarSerialNoAuditado: End If ' Aqui es para indicar que el serial esta auditado SerialAuditado: MsgBox "Este equipo fue auditado, por favor registrelo en el modulo correspondiente 'Reg. Entradas o Reg. Salidas'" Borrar_Campos Range("B5").Select Exit Sub IngresarSerialNoAuditado: 'Inicio insertar linea en la hoja registro de equipos no auditados Las etiqueta "NuevoIngreso:" fueron eliminadas. Por favor indiquenme si hay algun error o se puede mejorar el codigo. Agradecido de antemano
  • Recently Browsing

    No registered users viewing this page.

×
×
  • Create New...

Important Information

Privacy Policy