Generar dos archivos XLSX por cada una de las hojas de trabajo
DAM, Se tiene un archivo B.xlsx con N hojas de trabajo. Se requiere una macro que genere por cada hoja dos archivos llamados tufxxxxxx y legalxxxxxx donde xxxxxx es el valor contenido en la celda A20. Los archivos tufxxxxxx y legalxxxxxx realmente son plantillas y contienen información de las hojas
El archivo B.xlsx contiene: Hoja1:
A B C
5 NIT YYYYYYY
10 Usuario ZZZZZZZ
20 Total 50.000
Tufyyyyyyy
B C D
5 YYYYYYY 50.000
10 Usuario ZZZZZZZ
11 Total YYYYYYY = C5*5/100
Legalyyyyyyy
A B C D
5 50.000 YYYYYYY =B5*12.5
10
Y ASI PARA CADA HOJA DE TRABAJO que pueden ser N hojas
1 Respuesta
H o l a: Envíame tu archivo de excel con la información. Además me envías 4 archivos de ejemplo, 2 de la hoja1 y 2 de la hoja2, es decir, necesito ver cómo quieres los archivos de salida. Me explicas con comentarios cuáles hojas estás generando. Entre más claro y explicado el ejemplo, más práctico será realizar la macro.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Luis Fernando Gomez Galeano” y el título de esta pregunta.
Te anexo la macro
Sub Generar_Archivos()
'---
' Por.Dante Amor
'---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set h1 = Sheets("TUC")
Set h2 = Sheets("Liquidacion")
'
ruta = ThisWorkbook.Path & "\"
For Each h In Sheets
Select Case LCase(h.Name)
Case LCase(h1.Name), LCase(h2.Name)
Case Else
h1.Cells.Replace What:="Hoja1", Replacement:=h.Name, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
h2.Cells.Replace What:="Hoja1", Replacement:=h.Name, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
nombre1 = h1.Name & "-" & h1.[B7].Value
nombre2 = h2.Name & "-" & h1.[B7].Value
h1.Copy
Set l2 = ActiveWorkbook
Set h3 = l2.Sheets(1)
h3.Cells.Copy
h3.[A1].PasteSpecial xlValues
l2.SaveAs Filename:=ruta & nombre1 & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
l2.Close False
'
h2.Copy
Set l2 = ActiveWorkbook
Set h3 = l2.Sheets(1)
h3.Cells.Copy
h3.[A1].PasteSpecial xlValues
l2.SaveAs Filename:=ruta & nombre2 & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
l2.Close False
'
h1.Cells.Replace What:=h.Name, Replacement:="Hoja1", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
h2.Cells.Replace What:=h.Name, Replacement:="Hoja1", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Select
Next
MsgBox "Archivos creados"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
