Como reducir esta macro extensa
Quisiera saber si esta macro se puede reducir de algún forma, ya que la tengo que ejecutar dos veces y la segunda vez lo hace 10 veces más lento, dejo los primeros 3 rangos que me calculan la distancia entre puntos cardinales y me calcula cual es el siguiente punto más cercano.
Sub hasta70()
Range("J3").Select
ActiveCell.FormulaR1C1 = "=SQRT((R2C8-RC[-2])^2+(R2C9-RC[-1])^2)"
Range("J3").Select
Selection.AutoFill Destination:=Range("J3:J500")
Range("J3:J500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows("3:500").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=Range("J3:J500"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SetRange Range("A3:O500")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("J4").Select
ActiveCell.FormulaR1C1 = "=SQRT((R3C8-RC[-2])^2+(R3C9-RC[-1])^2)"
Range("J4").Select
Selection.AutoFill Destination:=Range("J4:J500")
Range("J4:J500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows("4:500").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=Range("J4:J500"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SetRange Range("A4:O500")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("J5").Select
ActiveCell.FormulaR1C1 = "=SQRT((R4C8-RC[-2])^2+(R4C9-RC[-1])^2)"
Range("J5").Select
Selection.AutoFill Destination:=Range("J5:J500")
Range("J5:J500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows("5:500").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=Range("J5:J500"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SetRange Range("A5:O500")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
2 Respuestas
Application.ScreenUpdating=False
Al principio
[Hola
La grabadora de macros es útil para comenzar con VBA y/o para ver algunas propiedades de objetos del Excel, pero en general no se recomienda hacer las macros solo con la grabadora ya que el código que se obtiene de ella es "en bruto". Un ejemplo aplicado a tu macro; mira lo que hice con las primeras líneas:
Range("J3").FormulaR1C1 = "=SQRT((R2C8-RC[-2])^2+(R2C9-RC[-1])^2)"
Range("J3").AutoFill Destination:=Range("J3:J500")
Range("J3:J500"). Copy
Range("J3").PasteSpecial Paste:=xlPasteValues¿Notas la diferencia con lo que obtuviste con la grabadora de macros? (OJO, igual yo lo haría diferente pero lo dejo a tu forma para que se entienda).
En general, además, no se debe de usar Select, aquí algo al respecto:
Saludos]
Abraham Valencia
Hola Abraham, muchas gracias por tu pronta respuesta, como veras no se programar y fue la única solución que encontré con las pocas herramientas que tengo para lograr lo que quería. No sabría como seguir las líneas que me escribiste, para continuar con la macro, y entiendo que faltaría ordenar la columna J. Se que con instrucción for, seria mucho más reducida mi macro, pero no se como utilizarla. Agradezco tu ayuda. Saludis
Si bien no sabes programar, al menos para la parte de la columna J, guíate de lo que he enviado para que puedas reducir lo que tienes ahí. Sobre lo demás, pues si no tienes tiempo de aprender/leer/entender sobre VBA, sugiero que reduzcas lo sugerido y dejes tal cual lo demás, no debería seguir tardando tanto tiempo.
Abraham Valencia