Código VBA se atasca al ejecutar
Tengo el siguiente código y al ejecutar se atasca un poco
No se si se puede mejorar ya que no soy muy experto
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 Sub
1 Respuesta
Respuesta de Dante Amor
2
Vamos a mover esta línea al inicio del código:
Application.ScreenUpdating = False
Prueba nuevamente:
Sub AutoSuma()
Dim FilaSumas As Integer
Dim sngAnchoTotal As Long, sngAnchoCelda As Long, sngAlto As Long
Dim n As Long, i As Long
'
Application.ScreenUpdating = False
'
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
'
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 Sub
