Auto ajustar celdas combinadas con VBA
Tengo esta macro pero necesito extenderla hasta la fila 50
LLevo tiempo con ello pero no doy con la solución
Agradecería un poco de ayuda
If Not ActiveSheet.Range("B13:j13").MergeCells Then Exit Sub 'Si el rango B5:E5 de la hoja activa no est combinado, salir sin hacer nada
Dim sngAnchoTotal As Single, sngAnchoCelda As Single, sngAlto As Single
Dim n As Integer
For n = 2 To 10
sngAnchoTotal = sngAnchoTotal + ActiveSheet.Cells(5, n).ColumnWidth
Next n
With ActiveSheet.Range("B13")
sngAnchoCelda = .ColumnWidth
.HorizontalAlignment = xlJustify
.VerticalAlignment = xlJustify
.MergeCells = False
.ColumnWidth = sngAnchoTotal
ActiveSheet.Rows(13).AutoFit
sngAlto = .RowHeight
End With
With ActiveSheet
.Range("B13:j13").Merge
.Columns(2).ColumnWidth = sngAnchoCelda
.Rows(13).RowHeight = sngAlto
End With
End Sub
1 respuesta
Prueba esto, va de la fila 13 a la 50
Sub combinar_celdas()
Dim sngAnchoTotal As Long, sngAnchoCelda As Long, sngAlto As Long
Dim n As Long, i As Long
'
Application.ScreenUpdating = False
For i = 13 To 50
If ActiveSheet.Range("B" & i & ":J" & i).MergeCells Then
For n = 2 To 10
sngAnchoTotal = sngAnchoTotal + ActiveSheet.Cells(5, n).ColumnWidth
Next n
With ActiveSheet.Range("B" & i)
sngAnchoCelda = .ColumnWidth
.HorizontalAlignment = xlJustify
.VerticalAlignment = xlJustify
.MergeCells = False
.ColumnWidth = sngAnchoTotal
ActiveSheet.Rows(i).AutoFit
sngAlto = .RowHeight
End With
With ActiveSheet
.Range("B" & i & ":J" & i).Merge
.Columns(2).ColumnWidth = sngAnchoCelda
.Rows(i).RowHeight = sngAlto
End With
End If
Next i
Application.ScreenUpdating = True
End SubNota: En lo sucesivo, procura poner el código con el icono para Insertar código fuente:
Hola Dante gracias por la respuesta
Da error en esta linea ".ColumnWidth = sngAnchoTotal"
Realiza los siguientes pasos y en este orden:
1. Qué dice el mensaje de error.
2. Cuando se detenga la macro, presiona el botón depurar.
3. Acerca el mouse a la variable sngAnchoTotal y dime qué valor tiene.
4. También acerca el mouse a la variable i y dime qué número tiene.
5. Con ese número en la variable i
6. Revisa las celdas de la fila y el número de la variable i. Dime qué datos tienes en esas celdas.
sngAnchoTotal y dime qué valor tiene=275
la variable i y dime qué número tiene.=17
5. Con ese número en la variable 17
6. Revisa las celdas de la fila 17. Dime qué datos tienes en esas celdas de la fila 17.
La fila 17 solo tiene una fórmula igual que el resto
"=SI.ERROR(BUSCARV(A18;'DATOS MAESTROS'!A:F;2;0); " ")"
Al salir del depurador el autoajuste le ha realizado correctamente pero la fila 17 me ha descombinado las celdas
Hay la misma fórmula de la fila 13 a la 50
Lo que pasa que en la 17 en este caso no hay datos
Cambia tu fórmula para que te regrese vacío en lugar de un espacio en blanco.
=SI.ERROR(BUSCARV(A18;'DATOS MAESTROS'!A:F;2;0); "")
O tendrás problemas en todo lo que haga con esas celdas, no lo mismo "" a " ".
O ajusta en la macro para que salte las esas celdas.
Sub combinar_celdas()
Dim sngAnchoTotal As Long, sngAnchoCelda As Long, sngAlto As Long
Dim n As Long, i As Long
'
Application.ScreenUpdating = False
For i = 13 To 50
If Range("B" & i).Value = "" Or Range("B" & i).Value = " " Then
Else
If ActiveSheet.Range("B" & i & ":J" & i).MergeCells Then
For n = 2 To 10
sngAnchoTotal = sngAnchoTotal + ActiveSheet.Cells(5, n).ColumnWidth
Next n
With ActiveSheet.Range("B" & i)
sngAnchoCelda = .ColumnWidth
.HorizontalAlignment = xlJustify
.VerticalAlignment = xlJustify
.MergeCells = False
.ColumnWidth = sngAnchoTotal
ActiveSheet.Rows(i).AutoFit
sngAlto = .RowHeight
End With
With ActiveSheet
.Range("B" & i & ":J" & i).Merge
.Columns(2).ColumnWidth = sngAnchoCelda
.Rows(i).RowHeight = sngAlto
End With
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Lo que no se porque el rando B17:J17 que le tengo combinado igual que los de la fila 13 a la 50 con su misma formula le descombina
De la fila del rango b13:J13 hasta el B16:J16 funciona correctamente
LLega a rando B17:J17 y quita la combinacion de las celdas
He puesto datos desde B13:J13 hasta B30:J30 y sigue dando el error en B17:J17
Revisa qué otra cosa tienes en todas las celdas de la fila 17.
Realiza la prueba de la macro en otra hoja nueva. Solamente pon datos, no pongas fórmulas.
Hola Dante, no funciona, ahora se queda hasta la fila 19 y quita la combinación
No se si se puedo compartir el archivo
Hay que agregar esta línea:
sngAnchoTotal = 0
Te anexo la macro actualizada:
Sub combinar_celdas()
Dim sngAnchoTotal As Long, sngAnchoCelda As Long, sngAlto As Long
Dim n As Long, i As Long
'
Application.ScreenUpdating = False
For i = 13 To 50
If ActiveSheet.Range("B" & i & ":J" & i).MergeCells Then
sngAnchoTotal = 0
For n = 2 To 10
sngAnchoTotal = sngAnchoTotal + ActiveSheet.Cells(5, n).ColumnWidth
Next n
With ActiveSheet.Range("B" & i)
sngAnchoCelda = .ColumnWidth
.HorizontalAlignment = xlJustify
.VerticalAlignment = xlJustify
.MergeCells = False
.ColumnWidth = sngAnchoTotal
ActiveSheet.Rows(i).AutoFit
sngAlto = .RowHeight
End With
With ActiveSheet
.Range("B" & i & ":J" & i).Merge
.Columns(2).ColumnWidth = sngAnchoCelda
.Rows(i).RowHeight = sngAlto
End With
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub AutoSuma()
Dim FilaSumas As Integer
FilaSumas = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("O" & FilaSumas).FormulaLocal = "=SUMA(O13:O" & FilaSumas - 1 & ")"
' celda sin formula vacia en columna
Range("L13").Select
Do While ActiveCell <> Empty
ActiveCell.Offset(1, 0).Select
Loop
' pone texto y tamaño
ActiveCell.FormulaR1C1 = "TOTAL"
Range("C15").Select
With Selection.Font
.Name = "Arial"
.Size = 11
.Underline = xlUnderlineStyleNone
.Color = -16777216
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Dim sngAnchoTotal As Long, sngAnchoCelda As Long, sngAlto As Long
Dim n As Long, i As Long
'
Application.ScreenUpdating = False
For i = 13 To 50
If ActiveSheet.Range("B" & i & ":J" & i).MergeCells Then
sngAnchoTotal = 0
For n = 2 To 10
sngAnchoTotal = sngAnchoTotal + ActiveSheet.Cells(5, n).ColumnWidth
Next n
With ActiveSheet.Range("B" & i)
sngAnchoCelda = .ColumnWidth
.HorizontalAlignment = xlJustify
.VerticalAlignment = xlJustify
.MergeCells = False
.ColumnWidth = sngAnchoTotal
ActiveSheet.Rows(i).AutoFit
sngAlto = .RowHeight
End With
With ActiveSheet
.Range("B" & i & ":J" & i).Merge
.Columns(2).ColumnWidth = sngAnchoCelda
.Rows(i).RowHeight = sngAlto
End With
End If
Next i
Application.ScreenUpdating = True
On Error Resume Next
Range("K13:k100").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("A1").Select
Sheets("PLANTILLA").Name = Sheets("PLANTILLA").Range("C7")
End SubMil gracias Dante, por fin, puedo relajar
La he completado, y funciona. Solo que se traba un poco y tarda en ejecutar
Sale el reloj de arena 4 segundos y arranca
Ves algo raro?
Tendría que revisar tu código.
Valora esta respuesta y crea una nueva y pones el código completo.
