Quiero solucionar error en Macro que no funciona
Dante Buen dia pedirte tu apoyo nuevamente, tengo una macro que me ayuda a replicar un archivo excel varias veces pero con la condicionante de diferentes nombres.
Podrias colaborarme y explicarme en que me estoy equivocando por favor.
Macro.
Sub Crea_Libros()
'
' Crea libros a partir del MASTER y revisando la lista de SELECCION
' Libros utilizados: 1 - MASTER 2 - SELECCION 3 - NUEVO
'
Dim master, seleccion, ruta, nombre, archivo As String
Dim fila, columna, hoja, indice, limite As Long
Dim nuevo As Integer
ruta = "D:\documentos\transturin\tarifarios\"
master = "MASTER 2016.xls"
seleccion = "SELECCION 2016.xls"
nuevo = 3 'número de libro nuevo
limite = 12 'número límite de columna para revisar en la selección
Workbooks.Open (ruta & seleccion) 'abrir archivo de selección
For columna = 1 To limite
Workbooks.Add 'crear nuevo libro, el 3
indice = 0
Windows(master).Activate
Range("A1").Select
For hoja = 1 To Sheets.Count 'verificar todas las hojas del libro
Sheets(hoja).Activate 'activar hoja correspondiente
Windows(seleccion).Activate 'activar libro
Range("A1").Select
' archivo = Format(Cells(1, columna).Value, "00") & " - (" & Format(Date, "yyyy-mm-dd") & ")" 'rescatar el nombre de la primera fila
archivo = Format(Cells(1, columna).Value, "00") & " - 2016" 'rescatar el nombre de la primera fila
For fila = 2 To 22 'comienza en 2 porque la primera fila es titulo, 20 es el limite actual
nombre = Cells(fila, columna).Value 'obtener valor de la celda actual
Windows(master).Activate
If UCase(nombre) = UCase(Sheets(hoja).Name) Then 'verificar nombre
Cells.Select 'marcar celdas a copiar
Selection.Copy 'copiar lo marcado
Range("A1").Select 'elegir la primera celda
Windows(nuevo).Activate
indice = indice + 1
If Sheets.Count < indice Then 'verificar cantidad de hojas disponibles
Sheets.Add after:=Sheets(indice - 1) 'adicionar una nueva hoja al final de todas
End If
Sheets(indice).Activate 'activar hoja correspondiente
Range("A1").Select 'elegir la primera celda
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste 'pegar datos copiados
Sheets(indice).Name = nombre 'copiar nombre de hoja
'--------------- copiar formatos ---------------
With ActiveSheet.PageSetup
.PrintTitleRows = Windows(master).ActiveSheet.PageSetup.PrintTitleRows
.PrintTitleColumns = Windows(master).ActiveSheet.PageSetup.PrintTitleColumns
.PrintArea = Windows(master).ActiveSheet.PageSetup.PrintArea
.LeftHeader = Windows(master).ActiveSheet.PageSetup.LeftHeader
.CenterHeader = Windows(master).ActiveSheet.PageSetup.CenterHeader
.RightHeader = Windows(master).ActiveSheet.PageSetup.RightHeader
.LeftFooter = Windows(master).ActiveSheet.PageSetup.LeftFooter
.CenterFooter = Windows(master).ActiveSheet.PageSetup.CenterFooter
.RightFooter = Windows(master).ActiveSheet.PageSetup.RightFooter
.LeftMargin = Windows(master).ActiveSheet.PageSetup.LeftMargin
.RightMargin = Windows(master).ActiveSheet.PageSetup.RightMargin
.TopMargin = Windows(master).ActiveSheet.PageSetup.TopMargin
.BottomMargin = Windows(master).ActiveSheet.PageSetup.BottomMargin
.HeaderMargin = Windows(master).ActiveSheet.PageSetup.HeaderMargin
.FooterMargin = Windows(master).ActiveSheet.PageSetup.FooterMargin
.PrintHeadings = Windows(master).ActiveSheet.PageSetup.PrintHeadings
.PrintGridlines = Windows(master).ActiveSheet.PageSetup.PrintGridlines
.PrintComments = Windows(master).ActiveSheet.PageSetup.PrintComments
.CenterHorizontally = Windows(master).ActiveSheet.PageSetup.CenterHorizontally
.CenterVertically = Windows(master).ActiveSheet.PageSetup.CenterVertically
.Orientation = Windows(master).ActiveSheet.PageSetup.Orientation
.Draft = Windows(master).ActiveSheet.PageSetup.Draft
.PaperSize = Windows(master).ActiveSheet.PageSetup.PaperSize
.FirstPageNumber = Windows(master).ActiveSheet.PageSetup.FirstPageNumber
.Order = Windows(master).ActiveSheet.PageSetup.Order
.BlackAndWhite = Windows(master).ActiveSheet.PageSetup.BlackAndWhite
.Zoom = Windows(master).ActiveSheet.PageSetup.Zoom
End With
'--------------- fin copiar formatos ---------------
Range("A1").Select 'elegir la primera celda
End If
Windows(seleccion).Activate
Next
Windows(master).Activate
Range("A1").Select 'elegir la primera celda
Next
Application.DisplayAlerts = False
Windows(nuevo).Activate
ActiveWorkbook.SaveAs Filename:="D:\documentos\transturin\TARIFAS" \ " & archivo ', FileFormat:=xlWorkbookDefault, CreateBackup:=False, ConflictResolution:=2 'grabar el archivo nuevo en formato actual"
' ActiveWorkbook.SaveAs Filename:=ruta & archivo, FileFormat:=xlExcel8, CreateBackup:=False, ConflictResolution:=2 'grabar el archivo nuevo en formato Office 2003
Windows(archivo & ".xlsx").Close 'cerrar libro
Application.DisplayAlerts = True
Next
Windows(master).Activate
Range("A1").Select
Windows(seleccion).Close 'cerrar libro
MsgBox "Se terminó la copia de datos"
End Sub
1 Respuesta
H o l a:
Envíame tu archivo y me explicas cómo funciona, qué error te envía y en dónde se detiene la macro.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Juan Marcelo Rios Ricalde” y el título de esta pregunta.
Dante:
Agradezco la pronta respuesta, ya te envíe el mail con los adjunto necesarios para que funcione la macro.
Indicarte que al momento de ejecutar dicha Macro realiza los siguientes pasos.
1. Abre el archivo selección 2016, donde se tiene varias columnas con diferentes nombreejemplo columna "O", Columna "P" y asís sucesivamente.
2. Toma el archivo Master 2016 y empieza a realizar copia de este archivo con diferentes nombre.
3. Es Decir lo renombra con el nombre "O - 2016"
Pero debe copiar el mismo formato del archivo original
