Je travail dans un service de maintenance et j'ai récupéré un fichier se présentant comme un cahier de maintenance qui renvoie diverses infos technique de sites d'interventions. Celui-ci est très intéressant pour le service et peut se partager facilement mais ...
La personne qui travaillait sur ce fichier n'est plus la , elle a laissé le code admin pour accès fichier et vba (ADMIN1967) est il possible à partir de ce fichier d'apporter des améliorations car dès que j'essai une opération il se met en sauvegarde et se ferme ...
Sans etre pro, le code n'aide pas à la compréhension vu que la plupart du temps, les feuilles sont masquées, protégées, et la barre de formule désactivée. par pratique pour s'y retrouver..
c'es pour ca que j'ai ajouté une macro que tu peux utiliser pour tout voir et ainsi suivre plus facilemenent le déroulement du code
dans le module 2: Sub Deprotege()
Private Sub Workbook_Open()
nocompt = True
'timerstart = TimeValue(Now) 'j'ai isolé cà
' lookinstatusbar 'et cà
Application.ScreenUpdating = False
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Feuil1.ComboBox1.Text = "Sélectionner site >>"
Feuil1.ComboBox2.Text = "Sélectionner site >>"
' Masquage lignes/colonnes et barre formule
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
' DeMasquage des onglets
ActiveWindow.DisplayWorkbookTabs = True
Sheets("Login").Protect "ADMIN1967"
Sheets("Login").Visible = True ' seul Login sera visible
'On Error Resume Next
'Masquage des feuilles sauf Login qui est la 1ere feuille et protection des feuilles 2 à 7 uniquement
For n = 2 To Sheets.Count
Sheets(n).Visible = False
'If n < 8 Then Sheets(n).Protect "ADMIN1967"
If n < 9 Then Sheets(n).Protect "ADMIN1967"
Next
' on vide la cellule nom
Worksheets("Login").Range("D35") = ""
' on vide le textbox et on remet les ***
Worksheets("Login").TextBox_mdp = ""
Worksheets("Login").TextBox_mdp.PasswordChar = "*"
If Sheets("ACCUEIL").ProtectContents = False Then Sheets("ACCUEIL").Protect "ADMIN1967"
Sheets("ACCUEIL").EnableSelection = xlUnlockedCells
'Gestion compteur pour date et Login
Dim Auj&, ligne%
Auj = Date 'Auj = date du jour
If Application.CountIf(Range("Compteur[Dates]"), Auj) = 0 Then 'si date du jour n'existe pas dans colonne dates
Sheets("Cpt").ListObjects("Compteur").ListRows.Add 'ajouter une ligne
ligne = Sheets("Cpt").Range("Compteur").Rows.Count 'ligne = nombre de lignes du tableau (après l'ajout)
Sheets("Cpt").Range("Compteur[Dates]")(ligne) = Date 'dernière cellule de Dates = date du jour
Else
ligne = Application.Match(Auj, Sheets("Cpt").Range("Compteur[Dates]"), 0) 'sinon, ligne = position de correspondance dans Dates
End If
Sheets("Cpt").Range("Compteur[Login]")(ligne) = Sheets("Cpt").Range("Compteur[Login]")(ligne) + 1
Sheets("Cpt").Range("K1") = ligne 'place le n° ligne de la date en J1
End Sub
Re
cette procédure semble fermée le Fichier , je l'ai donc désactivé !
VB:
Sub lookinstatusbar() '
Dim heure1, x, y
On Error Resume Next
If Not rupturcycle Then
heure1 = TimeValue(Now)
x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
minute_max = TimeValue(durée_max)
y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
If TimeValue(y) < TimeValue("00:01:01") Then mess = " Attention fermeture dans moins d'une minute !!!": Beep Else mess = " il reste plus que : "
If y = 0 Then fermeture: Exit Sub
DoEvents
Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & " temps passé: " & x & mess & y
Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
End If
End Sub
et plus de fermeture(reste les erreurs a traiter)
jean marie
Alors @ChTi160 Toutes mes excuses
effectivement cette macro provoque la sortie
la manip que je viens de faire:
je passe en mode "Mode Création" et automatiquement la proc "lookinstatusbar" est lancée
cette procédure est semble t il executée toutes les 4 s (avec le doevents)
le fait de passer en mode création, la valeur y reste vide ce qui provoque la sortie....
j'ai essayé de rajouté une condition sur le y
VB:
Sub lookinstatusbar()
Dim heure1, x, y
On Error Resume Next
If Not rupturcycle Then
heure1 = TimeValue(Now)
x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
minute_max = TimeValue(durée_max)
y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
If TimeValue(y) < TimeValue("00:01:01") Then mess = " Attention fermeture dans moins d'une minute !!!": Beep Else mess = " il reste plus que : "
If y <> "" Then
If y = 0 Then
fermeture
Exit Sub
End If
End If
DoEvents
Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & " temps passé: " & x & mess & y
Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
End If
End Sub
il n'y a plus de fermeture.... mais.. toutes les 4s, on entend le bip windows...
donc
pour aller bricoler dans le VBA, il faut d'abord commenter cette macro
et ne pas oublier de la décommenter en sortant..
en attendant: voici le fichier avec quelques corrections:
1) toutes les range nommées en erreur de ref ont été supprimées
2) j'ai rajouté une range nommée (DataBase)
3) j'ai modifié la formule en C3 des feuilles "Intervenant" et "Prestataires" pour avoir le bon numéro
4) j'ai modifié le chargement des Combobox1 et 2 de la feuille Acceuil
j'ai supprimé la propriété ListFillRange qui ne prenait pas en compte l'ajout de lignes dans la base justement
les combo sont donc remplis à chaque fois que la feuille Acceuil est activée
Edit:
pour éviter le Bip toutes les 4s, j'ai modifié comme suit
VB:
Sub lookinstatusbar()
Dim heure1, x, y
On Error Resume Next
If Not rupturcycle Then
heure1 = TimeValue(Now)
x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
minute_max = TimeValue(durée_max)
y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
If y = "" Then y = "00:01:01"
If TimeValue(y) < TimeValue("00:01:01") Then mess = " Attention fermeture dans moins d'une minute !!!": Beep Else mess = " il reste plus que : "
If y <> "" Then
If y = 0 Then
fermeture
Exit Sub
End If
End If
DoEvents
Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & " temps passé: " & x & mess & y
Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
End If
End Sub
ca veut dire qu'une fois qu'on est passé en mode création, le compteur de temps n'est plus mis à jour: il faut fermer et rouvrir le fichier
et je n'avais pas précisé, mais j'ai aussi corrigé la fonction tri_base
VB:
Sub TRI_Base()
'
Application.EnableEvents = False
' Tri base de données
With ActiveSheet
Fin = .Range("DataBase").Rows.Count + 3
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("A5:A" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange ActiveSheet.Range("DataBase")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.EnableEvents = True
End Sub