Cómo generar "resumenes" en Excel por medio de Macros
Estoy tratando de realizar una macro que me permita generar hojas a partir de la columna A. Las hojas que genera es para cada uno de los grupos de los datos que se encuentra en esta lista, es decir una hoja para A, B, C, D y los que hayan. Además dichas hojas deben tener el nombre de estas, es decir A, B, C, D, etc. Lo que necesito realizar, lo más importante, es que La primer hoja tenga solamente los datos de las A y sus precios, la hoja B tenga los datos de todos los B que estén en la columna, y así sucesivamente con cada uno de los datos.
1 respuesta
. 01/08/16
Hola, Axel
Disculpa la demora, pero lo que solicitas demanda una batería de controles, instrucciones y estructuras que deben ser probadas bajo distintas circunstancias.
Fue así que llegué al siguiente código donde sólo deberías validar las dos variables del inicio y luego hacer pruebas.
Entonces, accede al editor de VBA (atajo: Alt+F11) y pega este código en un módulo:
Sub CreaHojas()
'Rutina de agregado de hojas
'by FeJoAl
Dim HojaObjeto As Object
Application.StatusBar = ">>>>>>>>>>>>>> Un momento, generando archivo"
Application.ScreenUpdating = False
'Axel, completa estas dos variables:
ColNomb = "A" 'escribir letra de la columna donde están los nombres de hoja:
IniCell = "A1" 'Primera celda con datos en la hoja de destino
'-------- RUTINA PRINCIPAL
NomArchivo = ActiveWorkbook.Name
HojaPrinc = ActiveSheet.Name
NombHoja = ""
Ultfila = 0
ColNomb = ColNomb & "1:" & ColNomb & "40000"
ColCant = Range(ColNomb).CurrentRegion.Columns.Count
For Each CeldaAct In Sheets(HojaPrinc).Range(ColNomb)
If Not IsEmpty(CeldaAct) Then 'barrido de columna de nombres
If CeldaAct.Value <> NombHoja Then
NombHoja = CeldaAct.Value
Ultfila = -1
'control de existencia de Hoja
On Error Resume Next
Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja)
If Err = 0 Then
QueHago = MsgBox("La hoja " & NombHoja & " ya existe en libro " & NomArchivo & " ¿Qué hacemo? ¿La reemplazamos?" & Chr(10) & "Presionar: " & Chr(10) & "SI, para reemplazarla" & Chr(10) & "NO, para agregarle datos a la ya existente. " & Chr(10) & "Cancelar, para salir sin hacer nada" & Chr(10), vbYesNoCancel, "HOJA YA EXISTENTE")
Select Case QueHago
Case 6 ' Sí, reemplazar hoja
Application.DisplayAlerts = False
HojaObjeto.Delete
Application.DisplayAlerts = True
GoTo AddHoja
Case 7 ' NO reemplazar, agregar datos a existentes
Ultfila = HojaObjeto.Range(IniCell).CurrentRegion.Rows.Count - 1
GoTo AddData
Case 2 ' Cancelar
GoTo TheEnd
End Select
End If
On Error GoTo 0
Else
GoTo AddData
End If
AddHoja:
'creación de la hoja
On Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NombHoja
Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja)
GoTo AddData
AddData:
'copiado de datos a hoja creada
Sheets(HojaPrinc).Select
Range(CeldaAct. Offset(0, 1), CeldaAct. Offset(0, ColCant - 1)). Copy
HojaObjeto. Range(IniCell).Offset(Ultfila + 1, 0). PasteSpecial xlPasteValues
HojaObjeto. Range(IniCell).Offset(Ultfila + 1, 0). PasteSpecial xlFormats
Application.CutCopyMode = False
Ultfila = Ultfila + 1
Else
GoTo TheEnd
End If
Next
TheEnd:
Set HojaObjeto = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Bien, este programa recorre la columna A, de donde tomará los nombres de cada hoja.
Luego, controla si existe la hoja nueva que pretendes agregar.
Si no existiera, la crea. Pero si ya existiera, muestra un mensaje para que decidas:
1.- Eliminarla y crear una nueva con los datos de la tabla
2.- Mantener la hoja existente, pero agregar los datos de la hoja
3.-Cancelar proceso
Me parece que lo más probable es que elijas la primera opción.
Si estuvieras seguro de que esto es lo que debe hacer siempre, podríamos bypassear esta pantalla de control.
Definido esto, la macro copiará las celdas desde la segunda columna hasta la última que tengas en tu planilla y pegará los valores y formatos en la hoja creada desde la celda inicial que le hayas definido en la variable.
Si no hubiera nada en esa celda inicial, pegará los datos a partir de ella.
Pero, si ya hubiera datos exportados, pegará lo nuevo en la celda inmediata inferior a la última línea ocupada.
Ok, Axel, prueba la rutina y luego me dices qué habría que corregir, eventualmente.
Un abrazo
Fernando
.
Hola Fernando, no hubo demoras, no te preocupes por eso. Acabo de probar tu macro, y tengo varias dudas al respecto. Modifiqué las dos variables que indicaste. ¿Eso solo tengo que modificar?, hasta donde la use solo me crea una hoja con el nombre "Hoja1", por otro lado, por las dudas (ya que es lo mas importante) yo necesito que me resuma por así decir los nombres de las Columna A (lo digo de nuevo por las dudas). Si hay mas de un A, quiero que genere una hoja sola con todos los datos de todos los A. Quizá es difícil de hacer o necesita de muchos códigos. Si esto es así se podría llegar a resolver de otra manera que he pensado. Pero en fin, la macro que me pasaste me ha dado un error: "1400 en tiempo de ejecución, error definido por la aplicación o el objeto". Otra duda, conviene indicar al comienzo de la macro un código que me seleccione la hoja? "sheets("x").select para que vaya a dicha hoja y realice todo, o simplemente si hago un botón, y le asigno la macro, y que dicho botón esté en la hoja obviamente, se resuelve el problema? Te agradezco por la respuesta, tiempo y dedicación Fernando.
.
Buenas, Axel
He probado la rutina con el ejemplo que enviaste y funciona correctamente.
Desde luego, asumí que la ejecutás desde la hoja donde está la tabla.
Por ello verás que hay una sentencia que toma el nombre de esa hoja para que vuelva a ella:
HojaPrinc = ActiveSheet.Name
Lo que puede ocurrir es que los nombres de la columna A estén generando algún conflicto para crearse.
Entonces te sugiero dos cosas:
1.- Prueba el procedimiento con un caso idéntico al ejemplo que me pasaste para ver que los resultados son los que buscás.
2.- Coloca en esta página una parte del listado de nombres de hojas que pretendes crear para que vea si allí puede haber algo que esté provocando el problema.
Espero tus comentarios.
Abrazo
Fernando
.
Bueno fer, agradezco de nuevo tu respuesta y dedicación. Acabo de probar la macro con el ejemplo que te pasé, y funciona bien, solo hay una detalle que es: cuando copia todo, y lo pega en la nueva hoja creada, la columna que indica el nombre al que pertenece "A" o "B" (etc), no aparece. Igual te muestro imagenes para que comprendas mejor lo que necesito, quizá soy yo quien no se expresa o que por medio del ejemplo que te pase entorpecí la macro.
Necesito que genere de todas las letras (A1,2,3,4,5 etc) genere una hoja para todas las A1, A2, etc. Si bien la macro que me pasaste funciona muy bien para el ejemplo que te pase, no comprendo por qué no sucede en esta planilla que es la verdadera que tengo, solo con otros datos. Por las dudas, lo digo de nuevo para no molestarte con "Idas y vueltas", a partir de todas las "letras" debe generar una hoja para cada una en donde aparecen toda la familia de las A1, A2. Si es mucho, se podría hacer de otra forma, y quizá de esa amnera sea más fácil. Igualmente te agradezco de nuevo toda la información y ayuda que me brindas. Saludos y buenas noches!
..
Buenas noches, Axel
Por un momento pensé que el problema era que los nombres de hoja semejan direcciones de celda, pero eso no es el problema porque, las usé en mi modelo y las generó correctamente.
Respecto a que no copia el nombre de la hoja, es porque así lo programé, entendiendo que el nombre de la hoja ya indicaba esa característica.
Por lo que observo en la imagen que enviaste, las referencias de hojas -a diferencia del primer ejemplo- NO están en orden.
Simplificaría que estuvieran ordenadas por esa tercera columna.
Si eso no fuera posible, avísame y veré de modificar la codificación para que reclasifique cada linea a la hoja que le corresponda.
OK. Prueba este código que adapté a lo que alcanzo a ver en tu imagen:
Sub CreaHojas()
'Rutina de agregado de hojas
'by FeJoAl
Dim HojaObjeto As Object
Application.StatusBar = ">>>>>>>>>>>>>> Un momento, generando archivo"
Application.ScreenUpdating = False
'Axel, completa estas dos variables:
ColNomb = "C" 'escribir letra de la columna donde están los nombres de hoja:
IniCell = "A1" 'Primera celda con datos en la hoja de destino
'-------- RUTINA PRINCIPAL
NomArchivo = ActiveWorkbook.Name
HojaPrinc = ActiveSheet.Name
NombHoja = ""
Ultfila = 0
ColNomb = ColNomb & "2:" & ColNomb & "40000"
ColCant = Range(ColNomb).CurrentRegion.Columns.Count
For Each CeldaAct In Sheets(HojaPrinc).Range(ColNomb)
If Not IsEmpty(CeldaAct) Then 'barrido de columna de nombres
If CeldaAct.Value <> NombHoja Then
NombHoja = CeldaAct.Value
Ultfila = -1
'control de existencia de Hoja
On Error Resume Next
Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja)
If Err = 0 Then
QueHago = MsgBox("La hoja " & NombHoja & " ya existe en libro " & NomArchivo & " ¿Qué hacemo? ¿La reemplazamos?" & Chr(10) & "Presionar: " & Chr(10) & "SI, para reemplazarla" & Chr(10) & "NO, para agregarle datos a la ya existente. " & Chr(10) & "Cancelar, para salir sin hacer nada" & Chr(10), vbYesNoCancel, "HOJA YA EXISTENTE")
Select Case QueHago
Case 6 ' Sí, reemplazar hoja
Application.DisplayAlerts = False
HojaObjeto.Delete
Application.DisplayAlerts = True
GoTo AddHoja
Case 7 ' NO reemplazar, agregar datos a existentes
Ultfila = HojaObjeto.Range(IniCell).CurrentRegion.Rows.Count - 1
GoTo AddData
Case 2 ' Cancelar
GoTo TheEnd
End Select
End If
On Error GoTo 0
Else
GoTo AddData
End If
AddHoja:
'creación de la hoja
On Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NombHoja
Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja)
GoTo AddData
AddData:
'copiado de datos a hoja creada
Sheets(HojaPrinc).Select
Range(CeldaAct. Offset(0, -2), CeldaAct. Offset(0, ColCant - 3)). Copy
HojaObjeto. Range(IniCell).Offset(Ultfila + 1, 0). PasteSpecial xlPasteValues
HojaObjeto. Range(IniCell).Offset(Ultfila + 1, 0). PasteSpecial xlFormats
Application.CutCopyMode = False
Ultfila = Ultfila + 1
Else
GoTo TheEnd
End If
Next
TheEnd:
Set HojaObjeto = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End SubPuede ser que ahora funcione. Pero pruebalo y coméntame de nuevo. No es molestia que consultes de nuevo.
Abrazo
Fernando
.
Pd: La página NO está actualizando bien las respuestas. Tardan en aparecer lo que se escribe aquí desde la semana pasada. En fin...
¡Gracias! Fernando, acabo de copiar la macro y esta vez funcionó bien, no sé por qué antes no andaba correctamente, se ve que había modificado mal esas dos variables que me indicaste, ahora funciona muy bien! agradezco la respuesta y el esfuerzo. Lamento responderte tarde, pero ayer no me andaba la página. Saludos y muchas gracias!
.
Un placer, Axel. Sólo recuerda valorar estas respuestas de acuerdo a cómo fue resuelto tu problema.
Es cierto, la página estuvo funcionando mal estos dias y ayer estuvo caída.
Mientras tanto, con el nuevo modelo que pasaste de tu planilla, adapté la macro para que no requiera intervención humana y además que prescinda de que esté ordenada o no la planilla.
Esta otra rutina, distribuye las lineas de tu tabla en la hoja que corresponda.
Es decir, si la hoja no existe, la crea y le agrega los datos. Si existiera simplemente le asigna los datos que corresponda.
Puedes ejecutar esta macro cuantas veces necesites. Sólo recuerda eliminar las hojas existentes, caso contrario agregará los datos a continuación de la última linea.
Sub DistrxHoja() 'Rutina de distribución de registros por hoja 'by FeJoAl Dim HojaObjeto As Object Application.StatusBar = ">>>>>>>>>>>>>> Un momento, generando hojas" Application.ScreenUpdating = False 'Axel, completa estas dos variables: ColNomb = "C" 'escribir letra de la columna donde están los nombres de hoja: IniCell = "A1" 'Primera celda con datos en la hoja de destino '-------- RUTINA PRINCIPAL NomArchivo = ActiveWorkbook.Name HojaPrinc = ActiveSheet.Name NombHoja = "" Ultfila = 0 ColNomb = ColNomb & "2:" & ColNomb & "40000" ColCant = Range(ColNomb).CurrentRegion.Columns.Count For Each CeldaAct In Sheets(HojaPrinc).Range(ColNomb) If Not IsEmpty(CeldaAct) Then 'barrido de columna de nombres If CeldaAct.Value <> NombHoja Then NombHoja = CeldaAct.Value Ultfila = -1 'control de existencia de Hoja On Error Resume Next Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja) If Err = 0 Then GoTo AddData ' Implica que la hoja ya existe On Error GoTo 0 AddHoja: 'creación de la hoja On Error GoTo 0 Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = NombHoja Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja) GoTo AddData End If AddData: 'copiado de datos a hoja creada Sheets(HojaPrinc).Select Range(CeldaAct.Offset(0, -2), CeldaAct. Offset(0, ColCant - 3)). Copy HojaObjeto. Range(IniCell).Offset(Ultfila + 1, 0). PasteSpecial xlPasteValues HojaObjeto. Range(IniCell).Offset(Ultfila + 1, 0). PasteSpecial xlFormats Application.CutCopyMode = False Ultfila = Ultfila + 1 Else GoTo TheEnd End If Cont = Cont + 1 Next TheEnd: Set HojaObjeto = Nothing Application.StatusBar = False Application.ScreenUpdating = True MsgBox "Listo! " & Chr(10) & "Se transfirieron " & Cont & " líneas de registro" End Sub
Un abrazo
Fernando
.
.
Ok, sigue sin funcionar bien esto.
Te había pasado una macro autónoma para la generación de resúmenes independiente del orden que tuviera (o no) tu listado, pero no aparece.
Enigüey, utiliza este otro que agrega los mismos títulos de la hoja principal a cada hoja de resumen (supuesto que estuvieran en la fila 1 de tu planilla principal.
Sub DistrxHoja()
'Rutina de distribución de registros por hoja
'by FeJoAl
Dim HojaObjeto As Object
Application.StatusBar = ">>>>>>>>>>>>>> Un momento, generando hojas"
Application.ScreenUpdating = False
'Axel, completa estas dos variables:
ColNomb = "C" 'escribir letra de la columna donde están los nombres de hoja:
IniCell = "A1" 'Primera celda con datos en la hoja de destino
'-------- RUTINA PRINCIPAL
NomArchivo = ActiveWorkbook.Name
HojaPrinc = ActiveSheet.Name
NombHoja = ""
Ultfila = 0
ColNomb = ColNomb & "2:" & ColNomb & "40000"
Colcant = Range(ColNomb).CurrentRegion.Columns.Count
RangoTit = Sheets(HojaPrinc).Range("A1", Range("A1").Offset(0, Colcant - 1)).Address
For Each CeldaAct In Sheets(HojaPrinc).Range(ColNomb)
If Not IsEmpty(CeldaAct) Then 'barrido de columna de nombres
If CeldaAct.Value <> NombHoja Then
NombHoja = CeldaAct.Value
Ultfila = -1
'control de existencia de Hoja
On Error Resume Next
Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja)
If Err = 0 Then GoTo AddData ' Implica que la hoja ya existe
On Error GoTo 0
AddHoja:
'creación de la hoja
On Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NombHoja
Set HojaObjeto = ActiveWorkbook.Sheets(NombHoja)
Sheets(HojaPrinc).Range(RangoTit).Copy Range(IniCell)
GoTo AddData
End If
AddData:
'copiado de datos a hoja creada
Sheets(HojaPrinc).Select
Ultfila = HojaObjeto.Range(IniCell).CurrentRegion.Rows.Count - 1
Range(CeldaAct.Offset(0, -2), CeldaAct.Offset(0, Colcant - 3)).Copy
HojaObjeto.Range(IniCell).Offset(Ultfila + 1, 0).PasteSpecial xlPasteValues
HojaObjeto.Range(IniCell).Offset(Ultfila + 1, 0).PasteSpecial xlFormats
Application.CutCopyMode = False
Ultfila = Ultfila + 1
Else
GoTo TheEnd
End If
Cont = Cont + 1
Next
TheEnd:
Set HojaObjeto = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Listo! " & Chr(10) & "Se transfirieron " & Cont & " líneas de registro"
End Sub
Espero que con esto quede todo resuelto. Acordate de evaluar la calidad de la solución.
Abrazo
Fernando
.
¡Gracias Fernando! ahí evalué la calidad, además la macro funciona bien, no es algo, por así decir, "serio" lo que estoy haciendo, pero había funcionado con la anterior, igualmente agradezco la corrección!
