¿Combinar celdas de una misma columna?
Necesito realizar una macro que me combine celdas de igual valor en la misma columna. Agradecería si alguien me pudiera ayudar ya que no tengo mucha idea en VBA y necesito realizarlo con urgencia. El tema es el siguiente, tengo una columna ordeanda alfabéticamente y me aparecen registros iguales, el problema es que son casi 62.000 filas y no acabaría si intentase realizarlo a mano. Lo que quiero es que dicha macro me recorra la columna y que me combine las celdas de la filas que tengan el mismo valor.
1 Respuesta
Respuesta de santiagomf
2
Prueba con este código.
Option Explicit
Sub agruparCeldasIguales()
Dim maxCol As Integer
Dim maxLin As Long
Dim nCol As Integer
Dim i As Integer
Dim j As Integer
Dim miHoja As Worksheet
Set miHoja = ActiveSheet
' Buscamos la última celda de datos y cogemos el número de filas y columnas
maxCol = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Column
maxLin = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Row
' Para cada columna (si fuese sólo en una se pone su valor y listo)
For nCol = 1 To maxCol
i = 1
Do While i < maxLin
j = i + 1
If miHoja.Cells(i, nCol) <> "" Then ' Si la celda no está en blanco...
' Si la celda de la línea i es igual que la de j es repetida. Seguimos
' hasta encontrar una diferente
Do While miHoja.Cells(i, nCol) = miHoja.Cells(j, nCol) ' Celda repetida?
j = j + 1
Loop
If i < j - 1 Then ' Se han repetido celdas. Las unimos
Application.DisplayAlerts = False
miHoja.Range(miHoja.Cells(i, nCol), miHoja.Cells(j - 1, nCol)).Merge
miHoja.Range(miHoja.Cells(i, nCol), miHoja.Cells(j - 1, nCol)).VerticalAlignment = xlCenter
Application.DisplayAlerts = True
i = j - 1
End If
End If
i = i + 1
Loop
Next nCol
MsgBox "Proceso terminado"
End Sub
Option Explicit
Sub agruparCeldasIguales()
Dim maxCol As Integer
Dim maxLin As Long
Dim nCol As Integer
Dim i As Integer
Dim j As Integer
Dim miHoja As Worksheet
Set miHoja = ActiveSheet
' Buscamos la última celda de datos y cogemos el número de filas y columnas
maxCol = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Column
maxLin = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Row
' Para cada columna (si fuese sólo en una se pone su valor y listo)
For nCol = 1 To maxCol
i = 1
Do While i < maxLin
j = i + 1
If miHoja.Cells(i, nCol) <> "" Then ' Si la celda no está en blanco...
' Si la celda de la línea i es igual que la de j es repetida. Seguimos
' hasta encontrar una diferente
Do While miHoja.Cells(i, nCol) = miHoja.Cells(j, nCol) ' Celda repetida?
j = j + 1
Loop
If i < j - 1 Then ' Se han repetido celdas. Las unimos
Application.DisplayAlerts = False
miHoja.Range(miHoja.Cells(i, nCol), miHoja.Cells(j - 1, nCol)).Merge
miHoja.Range(miHoja.Cells(i, nCol), miHoja.Cells(j - 1, nCol)).VerticalAlignment = xlCenter
Application.DisplayAlerts = True
i = j - 1
End If
End If
i = i + 1
Loop
Next nCol
MsgBox "Proceso terminado"
End Sub
