Macro para combinar celdas, cuando la información es igual
Existe una manera de combinar las celdas de una columna, cuya información sea la misma ¿?
Es decir, después de llenar un formato de 24 filas (sin contar con los títulos de las columnas), y después de ordenarlos alfabéticamente (Orden que se refleja en la columna A de manera numérica ya que son rutas), estas celdas de la columna A (ejemplo la celdas 2, 3, 4 o ...) cuyos valores sean iguales se combinen en una sola celda con el valor que en ellas había. ¿?
3 Respuestas
Prueba esta macro, cuenta y combina valores iguales
Sub celdas_combinadas()
Dim unicos As New Collection
Set datos = Range("a1").CurrentRegion
With datos
filas = .Rows.Count
.Sort _
key1:=Range(.Columns(1).Address), order1:=xlAscending, Header:=True
For i = 2 To filas
valor = .Cells(i, 1)
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)
fila = WorksheetFunction.Match(valor, .Columns(1), 0)
cuenta = WorksheetFunction.CountIf(.Columns(1), valor)
If cuenta = 0 Then GoTo siguiente
With .Cells(fila, 1).Resize(cuenta)
.Clear
.Merge
.Value = valor
.VerticalAlignment = xlCenter
End With
siguiente:
Next j
End With
End Sub
Excelente! Muchas gracias, pero tuve que modificar la hoja, y ahora tengo 4 líneas por encima de los datos, y ya no empieza en la columna A, ahora empieza en la columna B. Y la verdad no logro adaptarla.
Es decir, los datos comienzan desde la celda B5.
Podrías darme una mano ¿?
Agradecido de antemano
Este es el resultado de las modificaciones
Sub celdas_combinadas()
Dim unicos As New Collection
Set datos = Range("a5").CurrentRegion
With datos
filas = .Rows.Count
.Sort _
key1:=Range(.Columns(1).Address), order1:=xlAscending, Header:=True
For i = 2 To filas
valor = .Cells(i, 2)
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)
fila = WorksheetFunction.Match(valor, .Columns(2), 0)
cuenta = WorksheetFunction.CountIf(.Columns(2), valor)
If cuenta = 0 Then GoTo siguiente
With .Cells(fila, 2).Resize(cuenta)
.Clear
.Merge
.Value = valor
.VerticalAlignment = xlCenter
End With
siguiente:
Next j
End With
End Sub
Buenos dias, dislculpa la tardanza, problemas de salud.
Realice el cambio de codigo por el que me indicas, y me pide depurar, este fragmento de codigo es el que me sombrea en amarillo an solicitar la peticion de depuracion.
.Sort _ key1:=Range(.Columns(1).Address), order1:=xlAscending, Header:=True
Agradezco de antemano tu ayuda.
Cambia esa línea por esta.
.Sort _
key1:=Range(.Columns(2).Address), order1:=xlAscending, Header:=True
Gracias por responder.
Ya lo hice, y da el mismo error. Pide depurar y ombrea esa linea...
Este es el error que arroja al momento de precionar el boton.
Se ha producido el error "1004" en tiempo de ejecucion:
Para ello, es necesario que todas las celdas combinadas tengan el mismo tamaño.
El problema es que quieres correr la macro sobre celdas ya combinadas y al momento de ordenar eso no se va a poder, tienes que descombinar las celdas primero y rellenar los espacios en blanco porque también te va marcar un nuevo error
Si, me di cuenta hace un momento, habia olvidado que puse unas celdas debajo de la plantilla.
Habra alguna manera de hacer el orden y combinacion, solo en un numero determinado de lineas ¿?, es decir, de la linea 5 hasta la linea 28...
Es para que salgo todo impreso en una misma hoja...
Te dejo el link del archivo para que entiedas que es lo que quiero hacer
Cambia la línea
Set datos = Range("a5").CurrentRegion
por
Set datos = Range("a5:d28"")
OK, gracias, pero indica un error en .Clear.... ¿?
A mi no me marca error solo le hice un cambio más por estética que por funcionalidad
Cambia esta línea .clear por .clearcontents, la primera borra la información y el formato, la segunda solo la información.
No entiendo donde esta el error, me sigue diciendo :
Se ha producido el error "1004" en tiempo de ejecución:
Esta acción no se puede realizar en una celda combinada.
Y al dar al botón de depurar me manda a la línea de ".ClearContents"
No hay celdas combinadas dentro del rango! Y ahora ni ordena, ni agrupa...
Prueba agregando esta línea .columns(2).unmerge en esta parte de la macro
With datos .columns(2).unmerge filas = .Rows.Count .Sort _ key1:=Range(.Columns(1).Address), order1:=xlAscending, Header:=True For i = 2 To filas
Private Sub CommandButton1_Click() Application.DisplayAlerts = False Application.ScreenUpdating = False Temp = [A2]: Flag = False: a = 2 For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row + 1 If Cells(i, "A") = Temp Then Flag = True b = i Else If Flag = True Then With Range(Cells(a, "A"), Cells(b, "A")) .MergeCells = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End If Flag = False: Temp = Cells(i, "A"): a = i End If Next i Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
El código lo hice con un botón, pero puedes simplemente copiarlo en un macro.
Si te ayudó, no olvides puntuar.
Mauricio Abreu,
Adjunto código para el desarrollo de tu consulta para su revisión.
Sub Ordenar_Combinar_Datos()
Application.DisplayAlerts = False
Set Rango = Range(Range("A2"), Range("A2").End(xlDown))
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=Rango, Order:=xlAscending
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SetRange Range("A1").CurrentRegion
.Header = xlYes
.Apply
End With
x = 0: i = 1
On Error Resume Next
While i <= Rango.Rows.Count
If Rango.Cells(i, 1) = Rango.Cells(i + 1, 1) Then
x = x + 1
Else
Range(Cells(i + 1 - x, 1), Cells(i + 1, 1)).Merge
x = 0
End If
i = i + 1
Wend
Application.DisplayAlerts = True
End SubPor favor, no olvidar de valorar la respuestas.