Alguien puede proporcionarme una macro para desplazar rangos de celdas a distintas columnas de una hoja de Excel
Necesito modificar la situación del contenido de una hoja de Excel con varios miles de lineas para colocar datos cambiándolos de columnas para posteriormente poder elaborar una serie de tablas.
He podido realizar el proceso manualmente en un pequeño grupo de filas pero resulta muy laborioso para tantas filas.
La macro debería hacer lo siguiente:
Se parte de una celda seleccionada en una linea.
Se busca en las celdas de la fila "Texto 1"
Si se encuentra se corta un rango de 56 celdas (incluida la que contiene el texto) situadas a la derecha de la celda encontrada y se pega, en la misma fila, a partir de la columna DA.
Si no se ha encontrado el texto antes citado, o se ha finalizado el proceso anterior, se busca en la misma fila otra celda conteniendo "Texto 2".
Si se encuentra se corta un rango de 50 celdas (incluida la que contiene el texto) situadas a la derecha de la celda encontrada y se pega, en la misma fila, a partir de la columna BA.
Si no se ha encontrado el texto, o se ha finalizado el proceso anterior, se busca en la misma fila otra nueva celda conteniendo "Texto 3".
Si se encuentra se corta un rango de 24 celdas (incluida la que contiene el texto) situadas a la derecha de la celda encontrada y se pega, en la misma fila, a partir de la columna AA.
Si no se ha encontrado el texto, o se ha finalizado el proceso anterior, se salta a la fila siguiente y se repite la serie de procesos anteriores en la nueva fila.
El programa debe finalizar cuando se encuentre una fila vacía.
1 Respuesta
¿Puedes poner una captura de pantalla de tu información para comprendar exactamente lo que quieres?
Gracias por tu interés.
Dada la amplitud de la hoja de excel una captura de pantalla no mostraría nada interesante. Hay que considerar que la hoja tiene alrededor de 150 columnas que para mostrarlas en una pantalla habría que poner de una anchura tan escasa que no dejarían ver nada.
La estructura de una fila es la siguiente: Las seis primeras celdas contienen datos identificativos del conjunto de elementos que se muestran a continuación.
La celda séptima o sea la G contiene una etiqueta identificativa ( que yo he nominado por simplicidad Texto 1, Texto 2 y Texto 3, existiendo también el Texto 4 que no he citado puesto que no es necesario moverlo) detrás de la cual las celdas siguientes contienen denominaciones. Estas celdas pueden ser pocas o muchas. Yo he medido los espacios que pueden ocupar en los casos más desfavorables y he señalado los desplazamientos necesarios.A continuación y en la fila sin espacios interpuestos viene otra etiqueta identificativa de menor rango que la anterior (Si la primera era Texto 4, en esta celda solo puede venir Texto 3, Texto 2 o Texto 1) y un nuevo grupo de celdas con denominaciones y así hasta cuatro grupos. No en todas las filas se encuentran las cuatro etiquetas identificativas pudiendo ser menos o ninguna, pero siempre en este orden: Texto 4, que de existir esta siempre en la columna G, Texto 3, Texto 2 y Texto 1, seguidas de las denominaciones incluidas en el correspondiente grupo.
La macro que pretendo traslada los grupos citados (Etiqueta identificativa y denominaciones que la corresponden) a zonas separadas en la hoja, correspondiendo al grupo de Texto 4 las columnas de la G a la Z, la de Texto 3 las columnas de la AA a la AZ, la de Texto 2 las columnas de la BA a la CZ y la de Texto 1 a partir de la DA.
Grabando macros yo lo he conseguido para una fila, pero al ejecutar la macro en otra fila no funciona. Aunque si funcionara habría el problema de tener que irla ejecutando por filas (hay varios miles). Yo programé algunas cosas hace muchos años pero llevo cerca de 20 sin hacerlo y no estoy familiarizado con el lenguaje utilizado en Excel. De aquí viene mi petición de ayuda.
Saludos.
Entonces publica un email para solicitarte tu archivo y ya viendo tu información adaptar una de mis macros a lo que ocupas.
El archivo contiene información que se me ha cedido con el compromiso de no difundirla. Su difusión podría originar problemas.
Lógicamente pasarla a un agente al servicio de su Graciosa Majestad podría traerme serias consecuencias.
Saludos.
Bien este es un ejemplo sencillo con datos ficticios de lo que supongo necesitas, en ejemplo hay 512 filas con etiquetas en G1 texto1, texto2, texto3, texto4, lo primero que hace la macro es ordenarlos datos a partir de la columna G, luego hace un filtrado en la memoria dejando los las cuatro etiquetas para después contar cuantas hay de cada una y su ubicación teniendo estos datos envía la información a diferentes regiones de la hoja, tomalo como ejemplo.
Sub copiar()
Dim unicos As New Collection
Set funcion = WorksheetFunction
Set datos = Range("a1").CurrentRegion
columna = Range("g1").Column
With datos
columnas = .Columns.Count: filas = .Rows.Count
.Sort key1:=Range(.Columns(columna).Address), order1:=xlAscending
For i = 1 To filas
valor = .Cells(i, columna)
On Error Resume Next
unicos.Add valor, CStr(valor)
On Error GoTo 0
Next i
For j = 1 To unicos.Count
valor = unicos.Item(j)
cuenta = funcion.CountIf(.Columns(columna), valor)
fila = funcion.Match(valor, .Columns(columna), 0)
Set origen = .Rows(fila).Resize(cuenta, columnas)
If j = 1 Then Set destino = Range("da1").Resize(cuenta, columnas)
If j = 2 Then Set destino = Range("ba1").Resize(cuenta, columnas)
If j = 3 Then Set destino = Range("aa1").Resize(cuenta, columnas)
If j = 4 Then Set destino = Range("j1").Resize(cuenta, columnas)
destino.Value = origen.Value
Next j
End With
End Sub
Muchas gracias por el programa enviado que estudiare detenidamente en los próximos días.
Yo por mi parte partiendo de un macro que he grabado haciendo el proceso que he descrito y poniendo pegotes por un lado y por otro para ir evitando los errores que me iban apareciendo, he construido ya un macro que me funciona para un fila determinada.
Tengo que hacer unas modificaciones para que el numero de la fila se adapte a los saltos que tendré que hacer para que el programa se vaya ejecutando hacia abajo hasta llegar al final de la hoja:
Sub Macro1()
'
' Macro1 Macro
'
'
Rows("24:24").Select
Selection.Find(What:="T1", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If Not ActiveCell Is Nothing Then
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 56)).Select
Application.CutCopyMode = False
Selection.Cut
Range("DA24").Select
ActiveSheet.Paste
End If
Rows("24:24").Select
Selection.Find(What:="T2", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If Not ActiveCell Is Nothing Then
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 50)).Select
Selection.Cut
Range("BA24").Select
ActiveSheet.Paste
End If
Rows("24:24").Select
Selection.Find(What:="T3", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If Not ActiveCell Is Nothing Then
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 24)).Select
Selection.Cut
Range("AA24").Select
ActiveSheet.Paste
End If
End Sub
El programa resulta un tanto pedestre y se nota que proviene de fuentes muy diversas, pero yo me lo estoy pasando muy bien recordando los tiempos en que hacia programillas hace más de 15 años.
Saludos.
He intentado proporcionar más datos sobre lo que voy haciendo:
He aquí una captura de pantalla de una parte del archivo original modificado para hacer su contenido irreconocible pero manteniendo su estructura.
Aplicando la parte de la macro que llevo elaborado funciona bien cuando en la fila existe T1, T2 y T3, pero cuando falta alguna de estos tres elementos se interrumpe dando el aviso:
y apareciendo al depurar este cuadro:
y la hoja se ha transformado en la siguiente:
La línea 20 se ha movido bien, pero la 21 no porque no tenia T1.
En la pantalla de depuración esta resaltada la función de búsqueda de T1. Todo me hace pensar que la búsqueda ha generado un "nothing" que pese a mi bucle que creía que salvaría la dificultad, esto no es así.
Como no estoy familiarizado con el funcionamiento de esta Web he seguido añadiendo esto en la pregunta original.
¿Debo plantear otra al respecto?
Como en la imagen esta pantalla se ve muy pequeña añado debajo el texto al parecer conflictivo:
'Selecciona la fila de la celda activa
Rows(ActiveCell.Row).Select
'Busca en la linea una celda con T1
Selection.Find(What:="T1", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
' Si encuentra la celda ejecuta el If
If Not ActiveCell Is Nothing Then
' Selecciona un rango de 56 celdas a partir de la celda activa (la que contiene T1)
...
...
Por cierto ¿hay alguna forma de ver las imágenes que aparecen en los mensajes ampliadas?
Saludos.
Ese error se presenta cuando no encuentra el elemento que busca, ¿ya no entendí estas buscando mover la columna g y solo la columna g en 4 columnas de 56 filas y sobrescribiendo lo que exista en dichas columnas?, la macro que planteaste solo mueve los datos uno a uno y la instrucción de búsqueda que manejas solo busca un solo dato le falta el complemento para búsquedas múltiples solo vas a obtener como resultado el mover solo un elemento y por lo que veo si la piensas usar para miles de registros va a estar lentísima.
La macro que te pase hace búsquedas y cuenta por ejemplo busca T1 localiza la fila donde esta el primer registro, cuenta todos los T1 e inmediatamente los mueve a la intentar que se ha establecido en la macro, lo mismo para las demás, solo faltaría agregarle las instrucciones para que corte en vez de copiar, esta seria la macro modificada.
Puedes subir a este tema tus dudas mientras seansobre la misma duda, respecto a como ampliar imágenes la única es subirla en partes.
Sub copiar()
Dim unicos As New Collection
Set datos = Range("a1").CurrentRegion
With datos
filas = .Rows.Count: columnas = .Columns.Count
col = Range("g1").Column
.Sort key1:=Range(.Columns(col).Address), order1:=xlAscending
For i = 1 To filas
etiqueta = .Cells(i, col)
On Error Resume Next
unicos.Add etiqueta, CStr(etiqueta)
On Error GoTo 0
Next i
For j = 1 To unicos.Count
etiqueta = unicos.Item(j)
cuenta = WorksheetFunction.CountIf(.Columns(7), etiqueta)
fila = WorksheetFunction.Match(etiqueta, .Columns(7), 0)
Set origen = .Cells(fila, col).Resize(cuenta, columnas - col)
If cuenta = 0 Or fila = 0 Then GoTo sal
If j = 1 Then Set destino = Range("da24:dz" & cuenta + 23)
If j = 2 Then Set destino = Range("ba24:cz" & cuenta + 23)
If j = 3 Then Set destino = Range("aa24:az" & cuenta + 23)
If j = 4 Then End
destino.Value = origen.Value
origen.Clear
Next j
End With
sal:
End Sub
