Intégration d'une barre de progression dans le déroulement d'une suite de macro
jackypirate
Messages postés
3
Date d'inscription
vendredi 21 novembre 2008
Statut
Membre
Dernière intervention
16 décembre 2008
-
11 déc. 2008 à 16:49
jackypirate Messages postés 3 Date d'inscription vendredi 21 novembre 2008 Statut Membre Dernière intervention 16 décembre 2008 - 16 déc. 2008 à 11:06
jackypirate Messages postés 3 Date d'inscription vendredi 21 novembre 2008 Statut Membre Dernière intervention 16 décembre 2008 - 16 déc. 2008 à 11:06
6 réponses
cs_Orohena
Messages postés
577
Date d'inscription
vendredi 26 septembre 2008
Statut
Membre
Dernière intervention
20 novembre 2010
4
11 déc. 2008 à 18:35
11 déc. 2008 à 18:35
Bonjour jackypirate
Dans la liste Autres contrôles de la barre d'outils Boîte à outils contrôles, tu dois avoir un contrôle Microsoft Progress Bar Control.
Je suppose que la macro Progress Bar dont tu parles fait varier la largeur d'un rectangle ?
Amicalement
Dans la liste Autres contrôles de la barre d'outils Boîte à outils contrôles, tu dois avoir un contrôle Microsoft Progress Bar Control.
Je suppose que la macro Progress Bar dont tu parles fait varier la largeur d'un rectangle ?
Amicalement
jackypirate
Messages postés
3
Date d'inscription
vendredi 21 novembre 2008
Statut
Membre
Dernière intervention
16 décembre 2008
11 déc. 2008 à 21:54
11 déc. 2008 à 21:54
Bonjour Orohena
Merci pour l'intérêt porté à ma question
La macro téléchargé fonctionne avec un contrôle Frame, contrôle Label et un 3 ème contrôle Label pour l'affichage en pourcentage de la progression.
Merci pour l'intérêt porté à ma question
La macro téléchargé fonctionne avec un contrôle Frame, contrôle Label et un 3 ème contrôle Label pour l'affichage en pourcentage de la progression.
bigfish_le vrai
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
15
11 déc. 2008 à 23:25
11 déc. 2008 à 23:25
Salut,
Ci-dessous une fonction qui te permetra de piloter une progressbar: Cette fonction fonctionne avec un userform qui contient 2 controles label et un controle progressbar. Note que le poucentage de progression apparait dans la barre de titre de la form.
la forme s'appel ProgressBar
le premier label s'appel ActionEnCours
le second labe s'appel SousActionEnCours
Cette fonction est a mettre dans un module
Function UpdtProgressBar(Optional Msg1ProgressBar As String, Optional Msg2ProgressBar As String, Optional Target As Long, Optional MyTimer As Double 0, Optional MyStep As Long 0, Optional NumberOfStep As Long = 1)
Dim PrgBar As Long
With ProgressBar 'Ma form If Msg1ProgressBar "" Then Msg1ProgressBar .ActionEnCours.Caption
.ActionEnCours.Caption = Msg1ProgressBar 'le premier label
.SousActionEnCours.Caption = Msg2ProgressBar ' le second label
If Not MyStep = 0 Then 'si pas de d'etape intermediaire on prend alors en compte uniquement la valeur objective reçu
' la progressbar attend un long ors le nombre d'etape n'est peut etre pas un multiple de la valeur objective
' il va donc falloir adapter la valeur pour atteindre la valeur objective uniquement par des longs
' par exemple si la valeur objective est 5 et qu'il y a 3 etapes les valeurs de ces etapes seront : 1 2 2 ' autre exemple: Target 9, NumberOfStep 4 donc MyStep vaudra dans l'ordre de passage 2 2 2 3
If MyStep <= NumberOfStep - (Target Mod NumberOfStep) Then
PrgBar = Int(Target / NumberOfStep)
Else
PrgBar = Int(Target / NumberOfStep) + 1
End If
Else
PrgBar = Target
End If
If .ProgressBar1.Value + PrgBar > .ProgressBar1.Max Then
.ProgressBar1.Value = .ProgressBar1.Max
Else
.ProgressBar1.Value = .ProgressBar1.Value + PrgBar
End If
.Caption = "Processing " & .ProgressBar1.Value & "%"
End With
DoEvents
If MyTimer > 0 Then
Dim start As Double
start = Timer ' Set start time.
Do While Timer < start + MyTimer
DoEvents ' Yield to other processes.
Loop
End If
End Function
Comment l'utiliser :
1\ tu dois definire les etapes de deroulement de ton code pour determiner les endoits ou tu vas appeler cette fonction.
2\ definir la valeur maxi de du controle progressbar en generale jutilise 100 pour 100%
3\ definir la valeur de progression de chaque etape en generale je divises la valeur maxi par le nombre d'etape pour determiner la valeur de progression moyenne. Pourquoi moyenne et bien de temps en temps je vais donner moins de poid a certaines etapes et plus de poid a d'autres. Par exemple si tu a 10 etapes la moyenne sera de 10% mais tu peux considerer que certaines etapes ne valent que 5% de la progression et que d'autres valent 15%.
4\ utiliser la fonction ci-dessus a chaque etape dans ton code.
Dans l'exemple suivant je crees la liste des fichiers a copier par une recherche dans le repertoire specifier et sur un server, puis je copies ces fichiers dans le repertoir temp de l'utilisateur
A mettre dans un module cela peut etre le meme que le module de la fonction
Option Explicit
Dim ListFiles() As String
Sub start()
ProgressBar.Show
End Sub
Sub CreationListFiles()
Dim i As Long, FolderPath As String, NbFiles As Long, PartFileName As String
UpdtProgressBar "Connecting to the server...", , 5
'path
FolderPath = "\\server\Data\Public\R&D\Activity TimesSheet" '<---- a modifier
If Right(FolderPath, 1) <> "" Then FolderPath = FolderPath & "" '<---- a modifier
' the files will be reconize by the following string
PartFileName = "Activity_TimesSheet_"
' search for the files
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = FolderPath 'Look in path
.Filename = PartFileName & "*.xls" 'all files names that contain this string will be selected
.SearchSubFolders = False
.Execute
NbFiles = .FoundFiles.Count 'how many files ?
If NbFiles = 0 Then 'if finally no file found
MsgBox "Cannot find any file. Please, check the path specified. ", vbCritical, "Files error..."
Exit Sub
End If
ReDim ListFiles(NbFiles) 'we dimension the table according the file(s) number
'Write the file(s) infos
For i = 1 To NbFiles 'for each files found
ListFiles(i) = .FoundFiles(i)
UpdtProgressBar "Creating files list...", "File: " & Replace(LCase(.FoundFiles(i)), LCase(FolderPath & PartFileName), ""), 45, 0.05, i, NbFiles
Next i
.LookIn = ""
End With
UpdtProgressBar , ""
CopyFiles
End Sub
Sub CopyFiles()
Dim i As Long, TmpPath As String, FileNumber As Long
'we take the path of the current user temp directory
TmpPath = Environ("TEMP") & "\Activity Time Synthesis"
FileNumber = UBound(ListFiles())
If Dir(TmpPath, vbDirectory) = "" Then MkDir TmpPath
For i = 1 To FileNumber
UpdtProgressBar "Copying files " & Dir(ListFiles(i)), "To: " & TmpPath, 50, , i, FileNumber
On Local Error Resume Next
FileCopy ListFiles(i), TmpPath & Dir(ListFiles(i)) If Err 0 Then ListFiles(i) TmpPath & Dir(ListFiles(i))
Next
End Sub
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
Maitenant le code a mettre dans le code de la form progressbar
Private Sub UserForm_Activate()
CreationListFiles
UpdtProgressBar "Copying files is complete", , , 1
Unload Me
End Sub
Private Sub UserForm_Initialize()
Me.Caption = "Processing 0%"
Me.ProgressBar1.Value = 0
End Sub
Voila
A+
Ci-dessous une fonction qui te permetra de piloter une progressbar: Cette fonction fonctionne avec un userform qui contient 2 controles label et un controle progressbar. Note que le poucentage de progression apparait dans la barre de titre de la form.
la forme s'appel ProgressBar
le premier label s'appel ActionEnCours
le second labe s'appel SousActionEnCours
Cette fonction est a mettre dans un module
Function UpdtProgressBar(Optional Msg1ProgressBar As String, Optional Msg2ProgressBar As String, Optional Target As Long, Optional MyTimer As Double 0, Optional MyStep As Long 0, Optional NumberOfStep As Long = 1)
Dim PrgBar As Long
With ProgressBar 'Ma form If Msg1ProgressBar "" Then Msg1ProgressBar .ActionEnCours.Caption
.ActionEnCours.Caption = Msg1ProgressBar 'le premier label
.SousActionEnCours.Caption = Msg2ProgressBar ' le second label
If Not MyStep = 0 Then 'si pas de d'etape intermediaire on prend alors en compte uniquement la valeur objective reçu
' la progressbar attend un long ors le nombre d'etape n'est peut etre pas un multiple de la valeur objective
' il va donc falloir adapter la valeur pour atteindre la valeur objective uniquement par des longs
' par exemple si la valeur objective est 5 et qu'il y a 3 etapes les valeurs de ces etapes seront : 1 2 2 ' autre exemple: Target 9, NumberOfStep 4 donc MyStep vaudra dans l'ordre de passage 2 2 2 3
If MyStep <= NumberOfStep - (Target Mod NumberOfStep) Then
PrgBar = Int(Target / NumberOfStep)
Else
PrgBar = Int(Target / NumberOfStep) + 1
End If
Else
PrgBar = Target
End If
If .ProgressBar1.Value + PrgBar > .ProgressBar1.Max Then
.ProgressBar1.Value = .ProgressBar1.Max
Else
.ProgressBar1.Value = .ProgressBar1.Value + PrgBar
End If
.Caption = "Processing " & .ProgressBar1.Value & "%"
End With
DoEvents
If MyTimer > 0 Then
Dim start As Double
start = Timer ' Set start time.
Do While Timer < start + MyTimer
DoEvents ' Yield to other processes.
Loop
End If
End Function
Comment l'utiliser :
1\ tu dois definire les etapes de deroulement de ton code pour determiner les endoits ou tu vas appeler cette fonction.
2\ definir la valeur maxi de du controle progressbar en generale jutilise 100 pour 100%
3\ definir la valeur de progression de chaque etape en generale je divises la valeur maxi par le nombre d'etape pour determiner la valeur de progression moyenne. Pourquoi moyenne et bien de temps en temps je vais donner moins de poid a certaines etapes et plus de poid a d'autres. Par exemple si tu a 10 etapes la moyenne sera de 10% mais tu peux considerer que certaines etapes ne valent que 5% de la progression et que d'autres valent 15%.
4\ utiliser la fonction ci-dessus a chaque etape dans ton code.
Dans l'exemple suivant je crees la liste des fichiers a copier par une recherche dans le repertoire specifier et sur un server, puis je copies ces fichiers dans le repertoir temp de l'utilisateur
A mettre dans un module cela peut etre le meme que le module de la fonction
Option Explicit
Dim ListFiles() As String
Sub start()
ProgressBar.Show
End Sub
Sub CreationListFiles()
Dim i As Long, FolderPath As String, NbFiles As Long, PartFileName As String
UpdtProgressBar "Connecting to the server...", , 5
'path
FolderPath = "\\server\Data\Public\R&D\Activity TimesSheet" '<---- a modifier
If Right(FolderPath, 1) <> "" Then FolderPath = FolderPath & "" '<---- a modifier
' the files will be reconize by the following string
PartFileName = "Activity_TimesSheet_"
' search for the files
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = FolderPath 'Look in path
.Filename = PartFileName & "*.xls" 'all files names that contain this string will be selected
.SearchSubFolders = False
.Execute
NbFiles = .FoundFiles.Count 'how many files ?
If NbFiles = 0 Then 'if finally no file found
MsgBox "Cannot find any file. Please, check the path specified. ", vbCritical, "Files error..."
Exit Sub
End If
ReDim ListFiles(NbFiles) 'we dimension the table according the file(s) number
'Write the file(s) infos
For i = 1 To NbFiles 'for each files found
ListFiles(i) = .FoundFiles(i)
UpdtProgressBar "Creating files list...", "File: " & Replace(LCase(.FoundFiles(i)), LCase(FolderPath & PartFileName), ""), 45, 0.05, i, NbFiles
Next i
.LookIn = ""
End With
UpdtProgressBar , ""
CopyFiles
End Sub
Sub CopyFiles()
Dim i As Long, TmpPath As String, FileNumber As Long
'we take the path of the current user temp directory
TmpPath = Environ("TEMP") & "\Activity Time Synthesis"
FileNumber = UBound(ListFiles())
If Dir(TmpPath, vbDirectory) = "" Then MkDir TmpPath
For i = 1 To FileNumber
UpdtProgressBar "Copying files " & Dir(ListFiles(i)), "To: " & TmpPath, 50, , i, FileNumber
On Local Error Resume Next
FileCopy ListFiles(i), TmpPath & Dir(ListFiles(i)) If Err 0 Then ListFiles(i) TmpPath & Dir(ListFiles(i))
Next
End Sub
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
Maitenant le code a mettre dans le code de la form progressbar
Private Sub UserForm_Activate()
CreationListFiles
UpdtProgressBar "Copying files is complete", , , 1
Unload Me
End Sub
Private Sub UserForm_Initialize()
Me.Caption = "Processing 0%"
Me.ProgressBar1.Value = 0
End Sub
Voila
A+
cs_Orohena
Messages postés
577
Date d'inscription
vendredi 26 septembre 2008
Statut
Membre
Dernière intervention
20 novembre 2010
4
11 déc. 2008 à 23:42
11 déc. 2008 à 23:42
ok, la macro que tu as téléchargée doit faire à peu près comme le Sub Demo() ci-dessous. Je te propose de l'essayer. Tu peux le paramétrer selon tes préférences, je t'ai indiqué les paramètres par des commentaires.
Sub demo()
Dim i As Double
barreProgression action:="CREER"
For i = 0 To 100 Step 0.5
DoEvents
barreProgression action:="METTRE_A_JOUR", pourcentage:=i
Next
barreProgression action:="SUPPRIMER"
End Sub
<hr />
Sub barreProgression(ByVal action As String, Optional pourcentage As Double)
Dim s As Shape
Dim pc As Double
Dim couleur As Long
Static large As Integer
' Paramètres
Const HAUTEUR_BARRE = 10 ' hauteur de la barre de progression en points
Const LARGEUR_INFO = 30 ' largeur de la barre de progression en points
Const MARGE = 20 ' largeur de la marge latérale en points
Const MARGE_INFERIEURE = 40 ' hauteur de la marge inférieure en points
Const TAILLE_CARACTERE = 8 ' taille de la police de caractères
couleur = RGB(128, 128, 128) ' couleur de la zone variable de la barre de progression
Select Case action
Case "CREER"
Dim bas As Integer
large = ActiveWindow.UsableWidth - 2 * MARGE - LARGEUR_INFO
bas = ActiveWindow.UsableHeight - MARGE_INFERIEURE
For Each s In ActiveSheet.Shapes
If Left(s.Name, 6) = "progb_" Then s.Delete
Next
ActiveSheet.Shapes.AddShape(msoShapeRectangle, MARGE, bas, large, HAUTEUR_BARRE).Select
Selection.Name = "progb_cadre"
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, large + MARGE - LARGEUR_INFO, bas, _
LARGEUR_INFO, HAUTEUR_BARRE).Select
Selection.Name = "progb_info"
Selection.Characters.Font.Size = TAILLE_CARACTERE
Selection.HorizontalAlignment = xlCenter
ActiveSheet.Shapes.AddShape(msoShapeRectangle, MARGE, bas, 0, HAUTEUR_BARRE).Select
With Selection
.ShapeRange.Fill.ForeColor.RGB = couleur
.ShapeRange.Line.Visible = msoFalse
.Name = "progb_curseur"
End With
Case "SUPPRIMER"
For Each s In ActiveSheet.Shapes
If Left(s.Name, 6) = "progb_" Then s.Delete
Next
Case "METTRE_A_JOUR"
pc = IIf(Abs(pourcentage) > 100, 100, Abs(pourcentage))
ActiveSheet.Shapes("progb_curseur").Width = (large - LARGEUR_INFO) * pourcentage / 100
ActiveSheet.Shapes("progb_info").TextFrame.Characters.Text = Fix(pc) & "%"
Case Else
MsgBox "Le parametre action est invalide"
End Select
End Sub
Amicalement
Sub demo()
Dim i As Double
barreProgression action:="CREER"
For i = 0 To 100 Step 0.5
DoEvents
barreProgression action:="METTRE_A_JOUR", pourcentage:=i
Next
barreProgression action:="SUPPRIMER"
End Sub
<hr />
Sub barreProgression(ByVal action As String, Optional pourcentage As Double)
Dim s As Shape
Dim pc As Double
Dim couleur As Long
Static large As Integer
' Paramètres
Const HAUTEUR_BARRE = 10 ' hauteur de la barre de progression en points
Const LARGEUR_INFO = 30 ' largeur de la barre de progression en points
Const MARGE = 20 ' largeur de la marge latérale en points
Const MARGE_INFERIEURE = 40 ' hauteur de la marge inférieure en points
Const TAILLE_CARACTERE = 8 ' taille de la police de caractères
couleur = RGB(128, 128, 128) ' couleur de la zone variable de la barre de progression
Select Case action
Case "CREER"
Dim bas As Integer
large = ActiveWindow.UsableWidth - 2 * MARGE - LARGEUR_INFO
bas = ActiveWindow.UsableHeight - MARGE_INFERIEURE
For Each s In ActiveSheet.Shapes
If Left(s.Name, 6) = "progb_" Then s.Delete
Next
ActiveSheet.Shapes.AddShape(msoShapeRectangle, MARGE, bas, large, HAUTEUR_BARRE).Select
Selection.Name = "progb_cadre"
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, large + MARGE - LARGEUR_INFO, bas, _
LARGEUR_INFO, HAUTEUR_BARRE).Select
Selection.Name = "progb_info"
Selection.Characters.Font.Size = TAILLE_CARACTERE
Selection.HorizontalAlignment = xlCenter
ActiveSheet.Shapes.AddShape(msoShapeRectangle, MARGE, bas, 0, HAUTEUR_BARRE).Select
With Selection
.ShapeRange.Fill.ForeColor.RGB = couleur
.ShapeRange.Line.Visible = msoFalse
.Name = "progb_curseur"
End With
Case "SUPPRIMER"
For Each s In ActiveSheet.Shapes
If Left(s.Name, 6) = "progb_" Then s.Delete
Next
Case "METTRE_A_JOUR"
pc = IIf(Abs(pourcentage) > 100, 100, Abs(pourcentage))
ActiveSheet.Shapes("progb_curseur").Width = (large - LARGEUR_INFO) * pourcentage / 100
ActiveSheet.Shapes("progb_info").TextFrame.Characters.Text = Fix(pc) & "%"
Case Else
MsgBox "Le parametre action est invalide"
End Select
End Sub
Amicalement
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
cs_Orohena
Messages postés
577
Date d'inscription
vendredi 26 septembre 2008
Statut
Membre
Dernière intervention
20 novembre 2010
4
11 déc. 2008 à 23:50
11 déc. 2008 à 23:50
Bigfish, tu me bousilles mon plan !
Moi qui espérais me faire offrir une bière par jackypirate
Adieu, veau, vache, cochon, couvées
(mais non, culpabilise pas, je plaisante ! )
Moi qui espérais me faire offrir une bière par jackypirate
Adieu, veau, vache, cochon, couvées
(mais non, culpabilise pas, je plaisante ! )
jackypirate
Messages postés
3
Date d'inscription
vendredi 21 novembre 2008
Statut
Membre
Dernière intervention
16 décembre 2008
16 déc. 2008 à 11:06
16 déc. 2008 à 11:06
Salut
Je reviens à mon problème, qui n'ai toujours pas résolut. J'ai testé les deux codes sans résultat (code de Bigfish_le vrai et de Orohena merci encore à vous 2).
Pour faire plus facile j'ai copié le code dans lequel j'aimerais intégrer une barre de progression, ce code se déroule en 5 étapes.
1_ copie des données graphiques
2_création de la nouvelle semaine
3_éffacement des données
4_sauvegarde sur le server (lecteur partagé N)
5_fermeture de la semaine
Sub Transfert_Données()
ChDir Application.DefaultFilePath + "\Relevés consommables"
Workbooks.Open Filename:="Relevé conso sem_0.xls"
ActiveSheet.Unprotect
ActiveWindow.ActivateNext
Données_graphique
Sheets("Graphique conso").Select
Données_graph = Range("A8:S60")
Sheets("Consommables").Select
Données_conso = Range("H8:H24")
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWindow.ActivateNext
ActiveWindow.ActivateNext
Sheets("Graphique conso").Select
ActiveSheet.Unprotect
Range("A8:S60") = Données_graph
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Consommables").Select
Range("F8:F24") = Données_conso
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("C1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
Range("C1").Select
Création_Semaine
Effacer_Données
Sauvegarde_sur_N
Fermer_Semaine
End Sub
'GESTION DE LA BOITE DE DIALOGUE CREATION SEMAINE
Sub Création_Semaine()
Application.ScreenUpdating = False
UserForm1.Show
End Sub
'GESTION DE LA BOITE DE DIALOGUE CREATION SEMAINE
Sub Créer_Semaine()
Semaine = UserForm1.ComboBox2.Value
Annee = UserForm1.ComboBox3.Value
selectionsemaine = Format$(Semaine, "00")
selectionannee = Format$(Annee, "0000")
UserForm1.Hide
nomfichSEMAINE = "Relevé consommables" & "-" & "Sem" & Format$(Semaine, "00") & "-" & Format$(Annee, "0000") & ".xls"
On Error GoTo PasDeFiche
ChDir Application.DefaultFilePath + "\Relevés consommables" + "\Semaine" + "\Année" & " " & Format$(Annee, "0000")
Workbooks.Open Filename:=nomfichSEMAINE
MsgBox ("Le classeur que vous voulez créer existe déjà")
Application.DisplayAlerts = False
ActiveWorkbook.Close
Création_Semaine
Exit Sub
PasDeFiche:
ChDir Application.DefaultFilePath + "\Relevés consommables"
Workbooks.Open Filename:="Relevé conso sem_0.xls"
Windows("Relevé conso sem_0.xls").Activate
ActiveSheet.Unprotect
Cells(1, 3) = Format$(Semaine, "00")
Cells(1, 4) = Format$(Annee, "0000")
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ChDir Application.DefaultFilePath + "\Relevés consommables" + "\Semaine" + "\Année" & " " & Format$(Annee, "0000")
ActiveWorkbook.SaveCopyAs nomfichSEMAINE
Windows("Relevé conso sem_0.xls").Activate
Sheets("Consommables").Select
ActiveSheet.Unprotect
Cells(1, 4) = ""
Cells(1, 3) = ""
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Sub Effacer_Données()
ChDir Application.DefaultFilePath + "\Relevés consommables"
Workbooks.Open Filename:="Relevé conso sem_0.xls"
ActiveSheet.Unprotect
Sheets("Consommables").Select
Range("F8:F25").Select
Selection.ClearContents
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("C1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Sub Sauvegarde_sur_N()
ActiveWorkbook.Protect "8973", Structure:=False, Windows:=False
On Error GoTo LecteurRéseauPasConnecté
ChDir "N:\ECHANGES\Trait_Donnees_CDTK2"
Workbooks.Open Filename:="N:\ECHANGES\Trait_Donnees_CDTK2\Bilan_Conso_Hebdo56.xls"
ActiveWorkbook.Protect "8973", Structure:=False, Windows:=False
ActiveWindow.ActivateNext
Sheets("Consommables").Select
ActiveSheet.Unprotect
Sheets("Consommables").Copy Before:=Workbooks("Bilan_Conso_Hebdo56.xls").Sheets(1)
On Error GoTo LaFeuilleExisteDéjà
Sheets("Consommables").Name = "sem" & " " & Cells(1, 3) & "-" & Cells(1, 4)
Worksheets("sem" & " " & Cells(1, 3) - 2 & "-" & Cells(1, 4)).Delete
ActiveWindow.Zoom = 85
With ActiveWindow
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = True
End With
Range("B1:D1").Select
Selection.Copy
Range("B5:D5").Select
ActiveSheet.Paste
Rows("1:2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("C3").Select
ActiveWorkbook.Protect "8973", Structure:=True, Windows:=False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
ActiveWindow.Close
Exit Sub
LaFeuilleExisteDéjà:
Application.DisplayAlerts = False
Worksheets("sem" & " " & Cells(1, 3) & "-" & Cells(1, 4)).Delete
Worksheets("sem" & " " & Cells(1, 3) - 2 & "-" & Cells(1, 4)).Delete
Sheets("Consommables").Name = "sem" & " " & Cells(1, 3) & "-" & Cells(1, 4)
ActiveWindow.Zoom = 85
With ActiveWindow
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = True
End With
Range("B1:D1").Select
Selection.Copy
Range("B5:D5").Select
ActiveSheet.Paste
Rows("1:2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("C3").Select
ActiveWorkbook.Protect "8973", Structure:=True, Windows:=False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
ActiveWindow.Close
Exit Sub
LecteurRéseauPasConnecté: Select Case MsgBox("Voulez-vous vous connecter au lecteur réseau N. Login KI00087 - Mot de passe K2pl56018", vbYesNo)
Case vbYes
MyAppID = Shell("D:\LOCAL\PLUS_IBD\NewLogin\LoginBK")
Sauvegarde_sur_N
Case vbNo
ActiveWorkbook.Protect "8973", Structure:=True, Windows:=False
ActiveWorkbook.Save
End Select
End Sub
'Fermeture semaine active
Sub Fermer_Semaine()
ActiveWorkbook.Protect "8973", Structure:=False
Application.ScreenUpdating = False
Application.CommandBars("Barre d'outils 56").Visible = True
Application.CommandBars("Barre d'outils conso").Visible = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Protect "8973", Structure:=True
ActiveWindow.Close SaveChanges:=True
End Sub
Je reviens à mon problème, qui n'ai toujours pas résolut. J'ai testé les deux codes sans résultat (code de Bigfish_le vrai et de Orohena merci encore à vous 2).
Pour faire plus facile j'ai copié le code dans lequel j'aimerais intégrer une barre de progression, ce code se déroule en 5 étapes.
1_ copie des données graphiques
2_création de la nouvelle semaine
3_éffacement des données
4_sauvegarde sur le server (lecteur partagé N)
5_fermeture de la semaine
Sub Transfert_Données()
ChDir Application.DefaultFilePath + "\Relevés consommables"
Workbooks.Open Filename:="Relevé conso sem_0.xls"
ActiveSheet.Unprotect
ActiveWindow.ActivateNext
Données_graphique
Sheets("Graphique conso").Select
Données_graph = Range("A8:S60")
Sheets("Consommables").Select
Données_conso = Range("H8:H24")
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWindow.ActivateNext
ActiveWindow.ActivateNext
Sheets("Graphique conso").Select
ActiveSheet.Unprotect
Range("A8:S60") = Données_graph
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Consommables").Select
Range("F8:F24") = Données_conso
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("C1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
Range("C1").Select
Création_Semaine
Effacer_Données
Sauvegarde_sur_N
Fermer_Semaine
End Sub
'GESTION DE LA BOITE DE DIALOGUE CREATION SEMAINE
Sub Création_Semaine()
Application.ScreenUpdating = False
UserForm1.Show
End Sub
'GESTION DE LA BOITE DE DIALOGUE CREATION SEMAINE
Sub Créer_Semaine()
Semaine = UserForm1.ComboBox2.Value
Annee = UserForm1.ComboBox3.Value
selectionsemaine = Format$(Semaine, "00")
selectionannee = Format$(Annee, "0000")
UserForm1.Hide
nomfichSEMAINE = "Relevé consommables" & "-" & "Sem" & Format$(Semaine, "00") & "-" & Format$(Annee, "0000") & ".xls"
On Error GoTo PasDeFiche
ChDir Application.DefaultFilePath + "\Relevés consommables" + "\Semaine" + "\Année" & " " & Format$(Annee, "0000")
Workbooks.Open Filename:=nomfichSEMAINE
MsgBox ("Le classeur que vous voulez créer existe déjà")
Application.DisplayAlerts = False
ActiveWorkbook.Close
Création_Semaine
Exit Sub
PasDeFiche:
ChDir Application.DefaultFilePath + "\Relevés consommables"
Workbooks.Open Filename:="Relevé conso sem_0.xls"
Windows("Relevé conso sem_0.xls").Activate
ActiveSheet.Unprotect
Cells(1, 3) = Format$(Semaine, "00")
Cells(1, 4) = Format$(Annee, "0000")
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ChDir Application.DefaultFilePath + "\Relevés consommables" + "\Semaine" + "\Année" & " " & Format$(Annee, "0000")
ActiveWorkbook.SaveCopyAs nomfichSEMAINE
Windows("Relevé conso sem_0.xls").Activate
Sheets("Consommables").Select
ActiveSheet.Unprotect
Cells(1, 4) = ""
Cells(1, 3) = ""
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Sub Effacer_Données()
ChDir Application.DefaultFilePath + "\Relevés consommables"
Workbooks.Open Filename:="Relevé conso sem_0.xls"
ActiveSheet.Unprotect
Sheets("Consommables").Select
Range("F8:F25").Select
Selection.ClearContents
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("C1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Sub Sauvegarde_sur_N()
ActiveWorkbook.Protect "8973", Structure:=False, Windows:=False
On Error GoTo LecteurRéseauPasConnecté
ChDir "N:\ECHANGES\Trait_Donnees_CDTK2"
Workbooks.Open Filename:="N:\ECHANGES\Trait_Donnees_CDTK2\Bilan_Conso_Hebdo56.xls"
ActiveWorkbook.Protect "8973", Structure:=False, Windows:=False
ActiveWindow.ActivateNext
Sheets("Consommables").Select
ActiveSheet.Unprotect
Sheets("Consommables").Copy Before:=Workbooks("Bilan_Conso_Hebdo56.xls").Sheets(1)
On Error GoTo LaFeuilleExisteDéjà
Sheets("Consommables").Name = "sem" & " " & Cells(1, 3) & "-" & Cells(1, 4)
Worksheets("sem" & " " & Cells(1, 3) - 2 & "-" & Cells(1, 4)).Delete
ActiveWindow.Zoom = 85
With ActiveWindow
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = True
End With
Range("B1:D1").Select
Selection.Copy
Range("B5:D5").Select
ActiveSheet.Paste
Rows("1:2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("C3").Select
ActiveWorkbook.Protect "8973", Structure:=True, Windows:=False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
ActiveWindow.Close
Exit Sub
LaFeuilleExisteDéjà:
Application.DisplayAlerts = False
Worksheets("sem" & " " & Cells(1, 3) & "-" & Cells(1, 4)).Delete
Worksheets("sem" & " " & Cells(1, 3) - 2 & "-" & Cells(1, 4)).Delete
Sheets("Consommables").Name = "sem" & " " & Cells(1, 3) & "-" & Cells(1, 4)
ActiveWindow.Zoom = 85
With ActiveWindow
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = True
End With
Range("B1:D1").Select
Selection.Copy
Range("B5:D5").Select
ActiveSheet.Paste
Rows("1:2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("C3").Select
ActiveWorkbook.Protect "8973", Structure:=True, Windows:=False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
ActiveWindow.Close
Exit Sub
LecteurRéseauPasConnecté: Select Case MsgBox("Voulez-vous vous connecter au lecteur réseau N. Login KI00087 - Mot de passe K2pl56018", vbYesNo)
Case vbYes
MyAppID = Shell("D:\LOCAL\PLUS_IBD\NewLogin\LoginBK")
Sauvegarde_sur_N
Case vbNo
ActiveWorkbook.Protect "8973", Structure:=True, Windows:=False
ActiveWorkbook.Save
End Select
End Sub
'Fermeture semaine active
Sub Fermer_Semaine()
ActiveWorkbook.Protect "8973", Structure:=False
Application.ScreenUpdating = False
Application.CommandBars("Barre d'outils 56").Visible = True
Application.CommandBars("Barre d'outils conso").Visible = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Protect "8973", Structure:=True
ActiveWindow.Close SaveChanges:=True
End Sub
