Ayuda para modificar un ejemplo de barra de progreso

30/08/2006 - 18:29 por ~ jose ~ | Informe spam

Hola, que hay?

Quiero poner una barra de progreso en un código que suele tardar como
1 minuto y medio en terminarse y la verdad, hay veces que no se si se
ha bloqueado o está trabajando.

La barra de progreso que me habia gustado era la que tiene dos barras
en un mismo formulario, he descargado el ejemplo de esta dirección:
http://www.erlandsendata.no/downloa...amples.zip
la opción 3, el formulario se llama "ProgressDlg2".
Lo que pasa es qeu no se aplicarlo a mi código, no se donde tengo que
ponerlo.

Mi código es este:

Sub EjecutarTodo()
'
' EjecutarTodo Macro
' Macro grabada el 17/08/2006 por Jose
'

'
inicio = Time
Sheets("ori").Select
Call ListarArchivosEnCarpeta
Sheets("500").Select
Call ListarArchivosEnCarpeta
Sheets("th").Select
Call ListarArchivosEnCarpeta
Sheets("Unión").Select
Call PegarFormulas
Sheets("Parámetros").Select
fin = Time
tiempo = fin - inicio
Range("B24") = (Format(tiempo, "nn") & " min. " & Format(tiempo,
"ss") & " seg.")
Range("B25").Select

End Sub

Por si no os hace falta descargar el archivo os pongo aquí el código
de ejemplo:

Para llamar al formulario:

Sub ShowDialog2()
Load ProgressDlg2
ProgressDlg2.Show
End Sub

Código del formulario:

Option Explicit

Private Sub UserForm_Activate()
Call Main2
End Sub

Private Sub UserForm_Initialize()
With Me.lblDone ' set the "progress bar" to it's initial length
.Top = Me.lblRemain.Top + 1
.Left = Me.lblRemain.Left + 1
.Height = Me.lblRemain.Height - 2
.Width = 0
End With
With Me.lblDone2 ' set the "progress bar" to it's initial length
.Top = Me.lblRemain2.Top + 1
.Left = Me.lblRemain2.Left + 1
.Height = Me.lblRemain2.Height - 2
.Width = 0
End With
End Sub

Código del módulo:

Sub Main2()
Dim i As Long, tot As Long
Dim j As Long, totJ As Long
tot = 5000
totJ = 5
ProgressDlg2.Caption = "Progress Dialog Title"
For j = 1 To totJ
For i = 1 To tot
If i Mod 10 = 0 Then ProgressBar2 "Copying file " & j & "
of " & totJ, j / totJ, "Writing record " & i & " of " & tot, i / tot
' do something
Next i
Next j
Unload ProgressDlg2
End Sub

Siga el debate

5 respuestas

Tengo una respuesta

Preguntas similare

Leer las respuestas

#1 ~ jose ~

30/08/2006 - 18:35 | Informe spam

Creo que esto no os hace falta pero os lo pongo por no dejar cabos
sueltos.

Codigo del ProgressBar2

Sub ProgressBar2(Msg1 As String, PctDone1 As Single, Msg2 As String,
PctDone2 As Single)
With ProgressDlg2
.lblMessage.Caption = Msg1
.lblDone.Width = PctDone1 * (.lblRemain.Width - 2)
.lblPct.Caption = Format(PctDone1, "0%")
.lblMessage2.Caption = Msg2
.lblDone2.Width = PctDone2 * (.lblRemain2.Width - 2)
.lblPct2.Caption = Format(PctDone2, "0%")
End With
'The DoEvents statement is responsible for the form updating
DoEvents
End Sub

Responder a este mensaje

#2 KL

31/08/2006 - 22:10 | Informe spam

Hola Jose,

Me parece que tu codigo tal como lo expones no tiene suficiente estructura para hacer un dialogo de progreso de 2 barras. Esas
barras estan disenadas par 2 bucles (uno dentro del otro). Para intentar adaptar tu codigo a esta solucion mi propuesta seria:

1) que expongas las rutinas 'ListarArchivosEnCarpeta', 'ListarArchivosEnCarpeta' y 'PegarFormulas' uno por uno (uno por cada
consulta) para intentar depurarlos ya que me parece demasiado largo el tiempo de ejecucion que mencionas para los macros con los
nombres que tienen. Probablemente una de las mejoras que se podria introducir de entrada seria la de usar
Application.ScreenUpdating=False.

2) una vez depuradas y optimizadas dichas rutinas, procederiamos a crear un codigo final adaptandolas a la estructura del
procedimiento 'Main2' que es lo unico que necesitas tocar para usar la solucion de Ole Erlandsen.

Saludos,
KL

Responder a este mensaje

#3 ~ jose ~

31/08/2006 - 22:32 | Informe spam

Hola,

Se trata de un archivo excel que utilizo para unir el texto de las
imagenes para un album de fotos en flash que requiere los nombres de
los archivos etc...

Extraigo los nombres de los archivos alojados en una carpeta, primero
lo ejecuto en la hoja "ori", me extra los archivos ahi (en este caso
son 49, tampoco son una burrada) y lo mismo para las carpetas "500" y
"th".
En la hoja "unión" es para unir el texto de las tres hojas y la hoja
"parámetros" es donde pongo la ruta de las carpetas donde se
encuentran los archivos de las tres hojas diferentes, la extensión
etc...

Lo de la barra de progreso era un poco capricho, es mas que nada para
saber si el programa está corriendo o no, y lo de emplear dos barras,
no me importa si se hace con una barra.
Bueno, aqui pongo los código completos, si hay alguna duda o quieres
que te mande el archivo, avisas vale?
Ah! otra cosa, la ruta de las hojas "500" y "th" son de un USB quizas
por eso tarda un poco mas de la cuenta.

PD: el USB es el 2, (un poco mas rapido que los anteriores)

Sub ListarArchivosEnCarpeta()
'Borrar datos
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("E1").Select
Selection.ClearContents
Range("A1").Select

Application.ScreenUpdating = False
Dim Carpeta As String, Fila As Long, Archivo, RutaCorta As String,
Criterios As String, Tmp As Range
Carpeta = Range("a1")
Fila = 4
Criterios = "a2:b2"
Set Tmp = Cells.Find(Empty)
Range("a3:g3") = Array( _
"Nombre", "Tamaño", "Tipo", "Creado", "Acceso", "Modificado",
"Nombre corto")
With CreateObject("Scripting.FileSystemObject")
With .GetFolder(Carpeta): RutaCorta = .ShortPath
For Each Archivo In .Files
With Archivo: Tmp = .Name
If Application.SumProduct(Application.CountIf(Tmp,
Range(Criterios))) Then
Range("a" & Fila & ":g" & Fila) = Array( _
.Name, .Size, .Type, .DateCreated, .DateLastAccessed,
.DateLastModified, .ShortName)
Fila = Fila + 1
End If
End With
Next
End With

Sub PegarFormulas()
'
' PegarFormulas Macro
' Macro grabada el 17/08/2006 por Jose
'

'
'BorrarDatosUnion
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("A1").Select

Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("A1").Select

Sheets("ori").Select
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Unión").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A4").Select
ActiveCell.FormulaR1C1 = "=IF('500'!RC>1,'500'!RC,"""")"
Range("B4").Select
ActiveCell.FormulaR1C1 = "=IF(th!RC[-1]>1,th!RC[-1],"""")"
Range("C4").Select
ActiveCell.FormulaR1C1 = _

"=IF(ori!RC[-2]>1,LEFT(ori!RC[-2],FIND(""|"",SUBSTITUTE(ori!RC[-2],""."",""|"",LEN(ori!RC[-2])-LEN(SUBSTITUTE(ori!RC[-2],""."",""""))))-1),"""")"
Range("D4").Select
ActiveCell.FormulaR1C1 = _

"=IF(AND(RC[-3]>1,RC[-2]>1,RC[-1]>1),RC[-2]&"",""&RC[-3]&"",""&RC[-1]&"";"","""")"
Range("A4:D4").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Sheets("ori").Select
Range("A1").Select
Sheets("Unión").Select
End Sub

KL wrote:

Hola Jose,

Me parece que tu codigo tal como lo expones no tiene suficiente estructura para hacer un dialogo de progreso de 2 barras. Esas
barras estan disenadas par 2 bucles (uno dentro del otro). Para intentar adaptar tu codigo a esta solucion mi propuesta seria:

1) que expongas las rutinas 'ListarArchivosEnCarpeta', 'ListarArchivosEnCarpeta' y 'PegarFormulas' uno por uno (uno por cada
consulta) para intentar depurarlos ya que me parece demasiado largo el tiempo de ejecucion que mencionas para los macros con los
nombres que tienen. Probablemente una de las mejoras que se podria introducir de entrada seria la de usar
Application.ScreenUpdating=False.

2) una vez depuradas y optimizadas dichas rutinas, procederiamos a crear un codigo final adaptandolas a la estructura del
procedimiento 'Main2' que es lo unico que necesitas tocar para usar la solucion de Ole Erlandsen.

Saludos,
KL

Responder a este mensaje

#4 KL

01/09/2006 - 15:00 | Informe spam

Hola jose,

Mi recomendacion era que saques los dos codigos como nuevas consultas independientes con el fin de depurar/optimizarlos (explicando,
eso si, que hacen y cual es el objetivo) y luego pasariamos a la siguiente fase de adaptar el codigo de la barra de progreso. Estoy
bastante liado y no podre hacer todo el trabajo yo solo al menos en las proximas semanas. Y ten cuaidado al copiar y pegar el
codigo - parece que al primer procedimiento le falta la parte final ;-)

Saludos,
KL

"~ jose ~" wrote in message news:
Hola,

Se trata de un archivo excel que utilizo para unir el texto de las
imagenes para un album de fotos en flash que requiere los nombres de
los archivos etc...

Extraigo los nombres de los archivos alojados en una carpeta, primero
lo ejecuto en la hoja "ori", me extra los archivos ahi (en este caso
son 49, tampoco son una burrada) y lo mismo para las carpetas "500" y
"th".
En la hoja "unión" es para unir el texto de las tres hojas y la hoja
"parámetros" es donde pongo la ruta de las carpetas donde se
encuentran los archivos de las tres hojas diferentes, la extensión
etc...

Lo de la barra de progreso era un poco capricho, es mas que nada para
saber si el programa está corriendo o no, y lo de emplear dos barras,
no me importa si se hace con una barra.
Bueno, aqui pongo los código completos, si hay alguna duda o quieres
que te mande el archivo, avisas vale?
Ah! otra cosa, la ruta de las hojas "500" y "th" son de un USB quizas
por eso tarda un poco mas de la cuenta.

PD: el USB es el 2, (un poco mas rapido que los anteriores)

Sub ListarArchivosEnCarpeta()
'Borrar datos
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("E1").Select
Selection.ClearContents
Range("A1").Select

Application.ScreenUpdating = False
Dim Carpeta As String, Fila As Long, Archivo, RutaCorta As String,
Criterios As String, Tmp As Range
Carpeta = Range("a1")
Fila = 4
Criterios = "a2:b2"
Set Tmp = Cells.Find(Empty)
Range("a3:g3") = Array( _
"Nombre", "Tamaño", "Tipo", "Creado", "Acceso", "Modificado",
"Nombre corto")
With CreateObject("Scripting.FileSystemObject")
With .GetFolder(Carpeta): RutaCorta = .ShortPath
For Each Archivo In .Files
With Archivo: Tmp = .Name
If Application.SumProduct(Application.CountIf(Tmp,
Range(Criterios))) Then
Range("a" & Fila & ":g" & Fila) = Array( _
.Name, .Size, .Type, .DateCreated, .DateLastAccessed,
.DateLastModified, .ShortName)
Fila = Fila + 1
End If
End With
Next
End With

Sub PegarFormulas()
'
' PegarFormulas Macro
' Macro grabada el 17/08/2006 por Jose
'

'
'BorrarDatosUnion
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("A1").Select

Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("A1").Select

Sheets("ori").Select
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Unión").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A4").Select
ActiveCell.FormulaR1C1 = "=IF('500'!RC>1,'500'!RC,"""")"
Range("B4").Select
ActiveCell.FormulaR1C1 = "=IF(th!RC[-1]>1,th!RC[-1],"""")"
Range("C4").Select
ActiveCell.FormulaR1C1 = _

"=IF(ori!RC[-2]>1,LEFT(ori!RC[-2],FIND(""|"",SUBSTITUTE(ori!RC[-2],""."",""|"",LEN(ori!RC[-2])-LEN(SUBSTITUTE(ori!RC[-2],""."",""""))))-1),"""")"
Range("D4").Select
ActiveCell.FormulaR1C1 = _

"=IF(AND(RC[-3]>1,RC[-2]>1,RC[-1]>1),RC[-2]&"",""&RC[-3]&"",""&RC[-1]&"";"","""")"
Range("A4:D4").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Sheets("ori").Select
Range("A1").Select
Sheets("Unión").Select
End Sub

KL wrote:

Hola Jose,

Me parece que tu codigo tal como lo expones no tiene suficiente estructura para hacer un dialogo de progreso de 2 barras. Esas
barras estan disenadas par 2 bucles (uno dentro del otro). Para intentar adaptar tu codigo a esta solucion mi propuesta seria:

1) que expongas las rutinas 'ListarArchivosEnCarpeta', 'ListarArchivosEnCarpeta' y 'PegarFormulas' uno por uno (uno por cada
consulta) para intentar depurarlos ya que me parece demasiado largo el tiempo de ejecucion que mencionas para los macros con los
nombres que tienen. Probablemente una de las mejoras que se podria introducir de entrada seria la de usar
Application.ScreenUpdating=False.

2) una vez depuradas y optimizadas dichas rutinas, procederiamos a crear un codigo final adaptandolas a la estructura del
procedimiento 'Main2' que es lo unico que necesitas tocar para usar la solucion de Ole Erlandsen.

Saludos,
KL

Responder a este mensaje

#5 ~ jose ~

01/09/2006 - 19:01 | Informe spam

Hola,
tampoco os quiero liar con esto, no es importante, es un poco capricho,
o curiosidad de como se podria poner una barra de progreso a cualquier
código.

Para agilizar el trabajo, podríamos hacerlo sin depurar el código?
No me importa que cueste mas tiempo en ejecutarse las macros, que
leches! asi se verá un poco mas la barra de progreso, jejeje.
Si es solo modificar subrutina 'Main2' supongo que será menos trabajo
para ti (o para quien sea), y si te cuesta aún menos aplicarlo a solo
una barra de los ejemplos de Ole Erlandsen tampoco me importa.

Vuelvo a poner el código uqe por descuido he cortado como bien dices.:

Sub ListarArchivosEnCarpeta()
'Borrar datos
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("E1").Select
Selection.ClearContents
Range("A1").Select

Application.ScreenUpdating = False
Dim Carpeta As String, Fila As Long, Archivo, RutaCorta As String,
Criterios As String, Tmp As Range
Carpeta = Range("a1") ': Range("a1,e1").ClearContents
Fila = 4
Criterios = "a2:b2" ' si necesitas mas 'criterios'... amplia las
columnas de este rango :)) '
Set Tmp = Cells.Find(Empty)
Range("a3:g3") = Array( _
"Nombre", "Tamaño", "Tipo", "Creado", "Acceso", "Modificado",
"Nombre corto")
With CreateObject("Scripting.FileSystemObject")
With .GetFolder(Carpeta): RutaCorta = .ShortPath
For Each Archivo In .Files
With Archivo: Tmp = .Name
If Application.SumProduct(Application.CountIf(Tmp,
Range(Criterios))) Then
Range("a" & Fila & ":g" & Fila) = Array( _
.Name, .Size, .Type, .DateCreated, .DateLastAccessed,
.DateLastModified, .ShortName)
Fila = Fila + 1
End If
End With
Next
End With
End With
Tmp.ClearContents: Set Tmp = Nothing
Range("a3:g3").EntireColumn.AutoFit: Range("e1") = RutaCorta

'Ordenar por nombre
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Sort Key1:=Range("A4"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
End Sub

Un saludo,
jose

KL wrote:

Hola jose,

Mi recomendacion era que saques los dos codigos como nuevas consultas independientes con el fin de depurar/optimizarlos (explicando,
eso si, que hacen y cual es el objetivo) y luego pasariamos a la siguiente fase de adaptar el codigo de la barra de progreso. Estoy
bastante liado y no podre hacer todo el trabajo yo solo al menos en las proximas semanas. Y ten cuaidado al copiar y pegar el
codigo - parece que al primer procedimiento le falta la parte final ;-)

Saludos,
KL

"~ jose ~" wrote in message news:
Hola,

Se trata de un archivo excel que utilizo para unir el texto de las
imagenes para un album de fotos en flash que requiere los nombres de
los archivos etc...

Extraigo los nombres de los archivos alojados en una carpeta, primero
lo ejecuto en la hoja "ori", me extra los archivos ahi (en este caso
son 49, tampoco son una burrada) y lo mismo para las carpetas "500" y
"th".
En la hoja "unión" es para unir el texto de las tres hojas y la hoja
"parámetros" es donde pongo la ruta de las carpetas donde se
encuentran los archivos de las tres hojas diferentes, la extensión
etc...

Lo de la barra de progreso era un poco capricho, es mas que nada para
saber si el programa está corriendo o no, y lo de emplear dos barras,
no me importa si se hace con una barra.
Bueno, aqui pongo los código completos, si hay alguna duda o quieres
que te mande el archivo, avisas vale?
Ah! otra cosa, la ruta de las hojas "500" y "th" son de un USB quizas
por eso tarda un poco mas de la cuenta.

PD: el USB es el 2, (un poco mas rapido que los anteriores)

Sub ListarArchivosEnCarpeta()
'Borrar datos
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("E1").Select
Selection.ClearContents
Range("A1").Select

Application.ScreenUpdating = False
Dim Carpeta As String, Fila As Long, Archivo, RutaCorta As String,
Criterios As String, Tmp As Range
Carpeta = Range("a1")
Fila = 4
Criterios = "a2:b2"
Set Tmp = Cells.Find(Empty)
Range("a3:g3") = Array( _
"Nombre", "Tamaño", "Tipo", "Creado", "Acceso", "Modificado",
"Nombre corto")
With CreateObject("Scripting.FileSystemObject")
With .GetFolder(Carpeta): RutaCorta = .ShortPath
For Each Archivo In .Files
With Archivo: Tmp = .Name
If Application.SumProduct(Application.CountIf(Tmp,
Range(Criterios))) Then
Range("a" & Fila & ":g" & Fila) = Array( _
.Name, .Size, .Type, .DateCreated, .DateLastAccessed,
.DateLastModified, .ShortName)
Fila = Fila + 1
End If
End With
Next
End With

Sub PegarFormulas()
'
' PegarFormulas Macro
' Macro grabada el 17/08/2006 por Jose
'

'
'BorrarDatosUnion
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("A1").Select

Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Range("A1").Select

Sheets("ori").Select
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Unión").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A4").Select
ActiveCell.FormulaR1C1 = "=IF('500'!RC>1,'500'!RC,"""")"
Range("B4").Select
ActiveCell.FormulaR1C1 = "=IF(th!RC[-1]>1,th!RC[-1],"""")"
Range("C4").Select
ActiveCell.FormulaR1C1 = _

"=IF(ori!RC[-2]>1,LEFT(ori!RC[-2],FIND(""|"",SUBSTITUTE(ori!RC[-2],""."",""|"",LEN(ori!RC[-2])-LEN(SUBSTITUTE(ori!RC[-2],""."",""""))))-1),"""")"
Range("D4").Select
ActiveCell.FormulaR1C1 = _

"=IF(AND(RC[-3]>1,RC[-2]>1,RC[-1]>1),RC[-2]&"",""&RC[-3]&"",""&RC[-1]&"";"","""")"
Range("A4:D4").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Sheets("ori").Select
Range("A1").Select
Sheets("Unión").Select
End Sub

KL wrote:
> Hola Jose,
>
> Me parece que tu codigo tal como lo expones no tiene suficiente estructura para hacer un dialogo de progreso de 2 barras. Esas
> barras estan disenadas par 2 bucles (uno dentro del otro). Para intentar adaptar tu codigo a esta solucion mi propuesta seria:
>
> 1) que expongas las rutinas 'ListarArchivosEnCarpeta', 'ListarArchivosEnCarpeta' y 'PegarFormulas' uno por uno (uno por cada
> consulta) para intentar depurarlos ya que me parece demasiado largo el tiempo de ejecucion que mencionas para los macros con los
> nombres que tienen. Probablemente una de las mejoras que se podria introducir de entrada seria la de usar
> Application.ScreenUpdating=False.
>
> 2) una vez depuradas y optimizadas dichas rutinas, procederiamos a crear un codigo final adaptandolas a la estructura del
> procedimiento 'Main2' que es lo unico que necesitas tocar para usar la solucion de Ole Erlandsen.
>
> Saludos,
> KL

Siga el debate Respuesta

Responder a este mensaje

Ads by Google

Hacer una pregunta

Tengo una respuesta

Busqueda sugerida