mostrar mensaje mientras se ejecuta un macro

Héctor Miguel escribió:

hola, leonardo !

... probe de la pagina de Ole P. Erlandsen, http://www.erlandsendata.no/downloa...amples.zip
el problema que no pude solucionar es que donde dice ' do something, en el codigo de la macro
(utilizo ShowDialog) coloco lo que quiero hacer (el macro que ya tenia lo llamo con call) y (es logico)
me rempite tantas veces se esta llenando la barra de progreso (entra como en un loop hasta que se agota el contador) soy claro?
como hago para que se ejecute mi macro y a la vez se muestre el formulario mientras se llena la barra de progreso
y al terminar la ejecución de mi macro se cierre el formulario? se deben ejecutar las macros simultaneamente?...

seria necesario 'ver' el codigo que estas utilizando [ya que hasta donde se]...

1) 'actualizar' una progressbar requiere 'decirle' al codigo en que momento 'avanza' el indicador [como, cuando, por que, etc.]
puede ser por bucles o 'detectando' alguna variable o 'momento' que te permita saber que ha habido cambios/avance/movimiento/...

2) si el caso es que las 'llamadas' al formulario lo estan mostrando -> dentro de un bucle...
podria darse el caso de entrar a 'bucles sin-fin' o muy leeenntos en su ejecucion [entre otra gama de probabilidades] :))

si cualquier duda [o informacion adicional]... comentas ?
saludos,
hector.

p.d. es necesario que expongas el codigo :D

Héctor:
LAMENTABLEMENTE NO ME DOY CUENTA, CREÍ QUE LO TENÍA!!!!!!!
te mando la planilla que contiene las macro.
la macro premiaciónniv1 como las otras dos similares son las que demoran
más en realizar los procesos y es a ellas que les quiero insertar la
barra de progreso.
me disculpo de antemano por la forma en que están programadas las macro,
pero estoy aprendiendo.
muchas gracias
Leo.

Héctor Miguel: te mando la macro, ya que no puedo enviar la planilla en
adjunto.
Saludos
Leonardo

como verás, la hoja ya existe: no sé cómo hacer para preguntar si existe
la hoja con ese nombre, en caso de no crearla y en caso de que exista ...

Sub premiaciónniv1()
' arma la hoja premiación para poder imprimir

''''''' selecciono la hoja y borro el contenido
''''''' esto lo hago por si presionan varias veces antes de
finalizar el torneo
Sheets("PREMIACIÓN NIVEL 1").Select
Cells.Select
Selection.ClearContents
Selection.Delete Shift:=xlUp

Sheets("Nivel 1").Select


Dim Mensaje, Estilo, Título, Ayuda, Ctxt, Respuesta, MiCadena
Mensaje = "Asegúrese que no hay una hoja en este libro que se llame
PREMIACIÓN. Si la hubiera, antes de seguir ELIMÍNELA, sino el programa
le dará un error. ¿Está seguro de seguir?" ' Define el mensaje.
Estilo = vbYesNoCancel + vbQuestion + vbDefaultButton2 ' Define los
botones.
Título = "¡¡¡ C U I D A D O !!!" ' Define el título.
Ayuda = "DEMO.HLP" ' Define el archivo de ayuda.
Ctxt = 1000 ' Define el tema

''''''''''''''''''''''''''''''''''''''''''

Dim Busca_1 As String, Busca_2 As String, Fila_1 As Integer, Fila_2
As Integer
Busca_1 = "PRE-INFANTIL"
Busca_2 = "INFANTIL"
Fila_1 = Evaluate("match(""" & Busca_1 & """,a:a,0)") + 1
Fila_2 = Evaluate("match(""" & Busca_2 & """,a:a,0)") - 1
'
acum = 0

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",0,1)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
''' temp cuenta los llenos
temp = ActiveCell.Value
acum = temp
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",1,0)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
'''' temp1 cuenta los vacíos
temp1 = ActiveCell.Value
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select


Range("a" & 7 & ":i" & 7 + temp).Select 'copio los títulos
Selection.Copy
Sheets("PREMIACIÓN NIVEL 1").Select
Range("A1").Select
ActiveSheet.Paste
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 1.71
Columns("I:I").EntireColumn.AutoFit
acum = acum + 2
Range("A" & acum).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''''' empiezo con 2º bloque
Sheets("Nivel 1").Select
Busca_1 = "INFANTIL"
Busca_2 = "INFANTIL A"
Fila_1 = Evaluate("match(""" & Busca_1 & """,a:a,0)") + 1
Fila_2 = Evaluate("match(""" & Busca_2 & """,a:a,0)") - 1
'

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",0,1)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
temp = ActiveCell.Value
acum = acum + temp
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",1,0)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
temp1 = ActiveCell.Value
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("a" & Fila_1 - 1 & ":i" & Fila_1 - 1 + temp).Select
Selection.Copy
Sheets("PREMIACIÓN NIVEL 1").Select
ActiveSheet.Paste
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 1.71
Columns("I:I").EntireColumn.AutoFit
acum = acum + 1
Range("A" & acum).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' empiezo con 3º bloque
Sheets("Nivel 1").Select
Busca_1 = "INFANTIL A"
Busca_2 = "INFANTIL B"
Fila_1 = Evaluate("match(""" & Busca_1 & """,a:a,0)") + 1
Fila_2 = Evaluate("match(""" & Busca_2 & """,a:a,0)") - 1
'

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",0,1)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
temp = ActiveCell.Value
acum = acum + temp
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",1,0)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
temp1 = ActiveCell.Value
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("a" & Fila_1 - 1 & ":i" & Fila_1 - 1 + temp).Select
Selection.Copy
Sheets("PREMIACIÓN NIVEL 1").Select
ActiveSheet.Paste
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 1.71
Columns("I:I").EntireColumn.AutoFit
acum = acum + 1
Range("A" & acum).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' empiezo con 4º bloque
Sheets("Nivel 1").Select
Busca_1 = "INFANTIL B"
Busca_2 = "JUVENIL"
Fila_1 = Evaluate("match(""" & Busca_1 & """,a:a,0)") + 1
Fila_2 = Evaluate("match(""" & Busca_2 & """,a:a,0)") - 1
'

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",0,1)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
temp = ActiveCell.Value
acum = acum + temp
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",1,0)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select

temp1 = ActiveCell.Value

Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("a" & Fila_1 - 1 & ":i" & Fila_1 - 1 + temp).Select
Selection.Copy
Sheets("PREMIACIÓN NIVEL 1").Select
ActiveSheet.Paste
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 1.71
Columns("I:I").EntireColumn.AutoFit
acum = acum + 1
Range("A" & acum).Select

''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' empiezo con 5º bloque
Sheets("Nivel 1").Select
Busca_1 = "JUVENIL"
Busca_2 = ""
Fila_1 = Evaluate("match(""" & Busca_1 & """,a:a,0)") + 1
If Busca_2 = "" Then Fila_2 = Range("G" & Rows.Count).End(xlUp).Row _
Else Fila_2 = Evaluate("match(""" & Busca_2 & """,a:a,0)") - 1
Range("a" & Fila_1 & ":G" & Fila_2).Sort _
Key1:=Range("G" & Fila_1), Order1:=xlDescending, Header:=xlNo
'

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",0,1)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
temp = ActiveCell.Value
acum = acum + temp
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("J" & Fila_1).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",1,0)"
Selection.AutoFill Destination:=Range("J" & Fila_1 & ":J" &
Fila_2), Type:=xlFillDefault
Range("j" & 3000).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2999]C:R[-1]C)"
Range("j" & 3000).Select
temp1 = ActiveCell.Value

Columns("J:J").Select
Selection.ClearContents
Range("A1").Select

Range("a" & Fila_1 - 1 & ":i" & Fila_1 - 1 + temp).Select
Selection.Copy
Sheets("PREMIACIÓN NIVEL 1").Select
ActiveSheet.Paste

'ajusto las columnas
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 1.71
Columns("I:I").EntireColumn.AutoFit

acum = acum + 1
Range("A" & acum).Select 'aquí estoy en la última fila en blanco de
la hoja premiación

'Range("a1").Select

Sheets("Nivel 1").Select
Application.CutCopyMode = False
Range("a1").Select

Call insertartítulo

Sheets("Nivel 1").Select
Range("a1").Select

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'' PREMIACIÓN POR EQUIPOS ''
'''''''''''''''''''''''''''''''''''''''''''''''''''''

'COPIA EL RANGO DE VALORES A LA HOJA TEMP


Sheets("TEMP").Visible = True
Sheets("TEMP").Select
Cells.Select
Selection.Delete Shift:=xlUp

Sheets("NIVEL 1").Select
Range("A8:G1000").Select
Selection.Copy

Sheets("TEMP").Select
Range("a2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Selection.Insert Shift:=xlDown
Sheets("Nivel 1").Select
Range("a1").Select
Sheets("TEMP").Select

'PONGO ROTULOS A LAS COLUMNAS

Range("A1").Select
ActiveCell.FormulaR1C1 = "NOMBRE"
Range("B1").Select
ActiveCell.FormulaR1C1 = "CLUB"
Range("C1").Select
ActiveCell.FormulaR1C1 = "AP1"
Range("D1").Select
ActiveCell.FormulaR1C1 = "AP2"
Range("E1").Select
ActiveCell.FormulaR1C1 = "AP3"
Range("F1").Select
ActiveCell.FormulaR1C1 = "AP4"
Range("G1").Select
ActiveCell.FormulaR1C1 = "TOTAL"

'ORDENO SEGÚN CLUB Y PUNTOS
Range("A2:G1000").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending,
Key2:=Range("G2") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom
Range("H1").Select

'COMPLETO CON LA FORMULA SI TIENE EL NOMBRE DEL CLUB

Range("I1").Select
ActiveCell.FormulaR1C1 = "CAMPUS"
Range("J1").Select
ActiveCell.FormulaR1C1 = "CAR"
Range("K1").Select
ActiveCell.FormulaR1C1 = "CDM"
Range("L1").Select
ActiveCell.FormulaR1C1 = "EDG"
Range("M1").Select
ActiveCell.FormulaR1C1 = "GYMNASTICS"
Range("N1").Select
ActiveCell.FormulaR1C1 = "OLIMPIA"
Range("O1").Select
ActiveCell.FormulaR1C1 = "PERFORMANCE"
Range("P1").Select
ActiveCell.FormulaR1C1 = "SOLIS"
Range("Q1").Select

Range("I2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(RC2=R1C,RC7,0)"
Range("I2").Select
Selection.AutoFill Destination:=Range("I2:P2"), Type:=xlFillDefault
Range("I2:P2").Select
Selection.AutoFill Destination:=Range("I2:P1000"), Type:=xlFillDefault
Range("I2:P1000").Select
ActiveWindow.SmallScroll Down:=-93

'COPIO LOS VALORES, ORDENO CADA COLUMNA Y SUMO LOS PROMEROS 9 VALORES

Range("I1:P1000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Range("I2:I1000").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("I2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("J2:J1000").Select
Selection.Sort Key1:=Range("J2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("K2:K1000").Select
Selection.Sort Key1:=Range("K2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("L2:L1000").Select
Selection.Sort Key1:=Range("L2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("M2:M1000").Select
Selection.Sort Key1:=Range("M2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("N2:N1000").Select
Selection.Sort Key1:=Range("N2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("O2:O1000").Select
Selection.Sort Key1:=Range("O2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("P2:P1000").Select
Selection.Sort Key1:=Range("P2"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll Down:=0
Range("I11").Select
ActiveCell.FormulaR1C1 = ""
Range("I11").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-9]C:R[-1]C)"
Range("I11").Select
Selection.AutoFill Destination:=Range("I11:P11"), Type:=xlFillDefault
Range("I11:P11").Select
Range("I11:P11").Select
Selection.Font.Bold = True
Range("T7").Select

ActiveWindow.ScrollColumn = 2
ActiveWindow.SmallScroll ToRight:=7
Range("I11").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-9]C:R[-1]C)"
Range("I11").Select
Selection.AutoFill Destination:=Range("I11:P11"), Type:=xlFillDefault
Range("I11:P11").Select
Range("I12").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-10]C:R[-2]C,""<>0"")"
Range("I12").Select
Selection.AutoFill Destination:=Range("I12:P12"), Type:=xlFillDefault
Range("I12:P12").Select
Range("I13").Select
ActiveCell.FormulaR1C1 = "=IF(R[-1]C=9,""SI"",""NO"")"
Range("I13").Select
Selection.AutoFill Destination:=Range("I13:P13"), Type:=xlFillDefault
Range("I13:P13").Select
Range("I1:P1,I11:P11,I13:P13").Select
Range("I13").Activate
Selection.Copy
Range("Q1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll ToRight:=6
Range("Q1:S8").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("R1"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Range("Q1:S8").Select
Selection.Copy
Sheets("PREMIACIÓN NIVEL 1").Select
Range("A" & acum + 9).Select

ActiveSheet.Paste ''pego la tabla chica
Range("A" & acum + 8 & ":d" & acum + 8).Select
Application.CutCopyMode = False
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = True
End With
Selection.Merge
With Selection.Font
.Name = "Arial"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
ActiveCell.Value = "PREMIACIÓN POR EQUIPOS"
ActiveWindow.SmallScroll Down:=5
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone

' termina premiación por equipos

' oculto la hoja temp
Sheets("TEMP").Select
ActiveWindow.SelectedSheets.Visible = False

End Sub

hola, Leo !

LAMENTABLEMENTE NO ME DOY CUENTA, CREI QUE LO TENIA!!!!!!!
te mando la planilla que contiene las macro.
la macro premiacionniv1 como las otras dos similares son las que demoran mas en realizar los procesos
y es a ellas que les quiero insertar la barra de progreso...

=> 'regresando' a lo comentado anteriormente...

1) 'actualizar' una progressbar requiere 'decirle' al codigo en que momento 'avanza' el indicador [como, cuando, por que, etc.]
puede ser por bucles o 'detectando' alguna variable o 'momento' que te permita saber que ha habido cambios/avance/movimiento/...

=> te 'marco' algunos comentarios en seguida :)

saludos,
hector.

-> en el codigo que expones [asumiendo que es igual a 'las otras dos similares'] :))

1) no existe una 'estructura' [como bucles For...Next] que permita que el codigo pueda 'avanzar' una barra de progreso 'programadamente'
[aunque tiene acciones 'repetitivas' que son 'materia dispuesta' para definirlos] :))

2) [seguramente] el tiempo que le/s toma puede resultar 'desesperante', pero se debe a la forma de [efectivamente] ir seleccionando objetos
p.e.: generalmente, no es necesario 'seleccionar' hojas/rangos/objetos/... para trabajar con sus metodos/propiedades/valores/... ;)

3) tampoco es de facil 'apreciacion' el valor que pudiera darse al total por avanzar de una progressbar, y por lo mismo...
a) es necesario determinar en que momento/accion/bucle/... conviene indicarle a la progressbar que ejecute un 'avance' [y de que valor] -?-

4) [probablemente] si llegas a no necesitar de la seleccion 'efectiva' de los objetos...
[seguramente] reduciras drasticamente el tiempo que se tarda la ajecucion de tus n_procedimientos -?-
[con lo cual] es posible que no se requiera usar una progressbar para indicar avances [una vez recortado el tiempo de ejecucion] -?-

lo que si... el codigo del ejemplo no es lo que se dice... 'ligero', y pudiera tener 'implicaciones' no apreciables 'a simple vista' -?-
en un 'tiempecito que me sobre'... tratare de ofrecerte una version 'depurada' [a menos que alguien mas en el foro se me adelante] :D

saludos,
hector.

Héctor Miguel: de acuerdo, entiendo lo que me explicaste muy claramente,
espero tus comentarios.
Saludos y hasta pronto.
leonardo

hola, Leo !

... entiendo lo que me explicaste muy claramente, espero tus comentarios...

por si todavia 'andas por aqui' :D

si la logica no se me ha ido muy lejos de vacaciones... [segun yo]...
la siguiente fraccion de codigo 'hace' el arreglo que necesitas de los 5 'bloques' [en menos lineas y tiempo]
no he llegado a las formulas que pones en la hoja 'temp' a partir de la columna 'I'
ni a los formatos que aplicas a ciertos rangos :-((
[y no se que haga la macro que llamas con nombre de: 'insertartítulo'] -???-

corre algunas pruebas con una copia de tus archivos originales y... comentas si vamos por buen camino ?
saludos,
hector.

Sub Agiliza_Premiacion()
Dim Busca As Variant, Sig As Byte, Fila_1 As Integer, Fila_2 As Integer
Busca = Array("pre-infantil", "infantil", "infantil a", "infantil b", "juvenil", "")
Worksheets("premiación nivel 1").Cells.Clear
Worksheets("nivel 1").Select
For Sig = LBound(Busca) To UBound(Busca) - 1
Fila_1 = Evaluate("match(""" & Busca(Sig) & """,a:a,0)") + 1
Fila_2 = IIf(Busca(Sig + 1) <> "", Evaluate("match(""" & Busca(Sig + 1) & """,a:a,0)") - 1, _
Range("g65536").End(xlUp).Row)
Range("a" & Fila_1 & ":i" & Fila_2).Copy _
Destination:=Worksheets("premiación nivel 1").Range("a65536").End(xlUp).Offset(2)
Next
Worksheets("premiación nivel 1").Columns("a:i").EntireColumn.AutoFit
Worksheets("premiación nivel 1").Columns("h:h").columnswidth = 1.71
insertartítulo ' ESTA MACRO NO SE QUE HACE ???'
With Worksheets("temp")
.Range("a1:g1") = Array("Nombre", "Club", "AP1", "AP2", "AP3", "AP4", "Total")
Worksheets("nivel 1").Range("a8:g1000").Copy Destination:=.Range("a2")
.Range("a2:g1000").Sort Key1:=Range("b2"), Order1:=xlAscending, _
Key2:=Range("g2"), Order2:=xlDescending, Header:=xlYes
.Range("i1:p1") = Array("Campus", "CAR", "CDM", "EDG", "Gymnastics", "Olimpia", "Performance", "Solis")
End With
' AQUI SEGUIRIAN LAS FORMULAS Y LOS FORMATOS ...'
End Sub

p.d. tampoco veo como es que llamas a algun MsgBox ??? [pero supongo que puedes usar constantes al inicio del modulo +/- asi]:

Public Const Mensaje As String = "Asegúrese que no hay una hoja en este libro que se llame PREMIACIÓN" & vbCr & _
"Si la hubiera, antes de seguir ELIMÍNELA, o el programa le dará un error" & vbCr & _
"¿Está seguro de seguir?" ' Define el mensaje
Public Const Estilo As Integer = vbYesNoCancel + vbQuestion + vbDefaultButton2 ' Define los botones
Public Const Título As String = "¡¡¡ C U I D A D O !!!" ' Define el título
Public Const Ayuda As String = "demo.hlp" ' Define el archivo de ayuda
Public Const Ctxt As Integer = 1000 ' Define el tema