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

3 Respuestas

1.375 pts. Si lo imaginas, lo puedes programar.

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.

191.775 pts. Si de mis mayores gustos, mis disgustos han nacido,...

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

https://goo.gl/E9Ngs9 

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
       
41.375 pts. La verdadera sabiduría está en saber que nunca terminas...

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 Sub

Por favor, no olvidar de valorar la respuestas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas