Problème d'enregistrement autour de mes fichiers
V
Bonjour, dans mon entreprise, plusieurs feuilles excel sont partagés en réseau.
Ceux que je met a dispo contiennent des macro.
A priori ce n'est pas un pb de droit puisque "souvent ça marche mais des fois pas".
le problème soulevé est celui la:
je vous met le code complet dessous, pensez vous qe l'erreur vienne de ma macro?
Sub alea()
Dim plage As Range
Dim cel As Range
Dim alea As Double
Dim alea2 As Double
Dim i As Integer
'désactivation de l'épilepsie
Application.ScreenUpdating = False
Sheets("Liste").Visible = True
Sheets("Liste").Select
'pour gagner du temps
Application.Calculation = xlManual
'vérif de condition de vidange avant de relancer
Sheets("Liste").Select
If Range("aw2") = 1 Or Range("aw3") = 1 Or Range("aw4") = 1 Then
MsgBox "merci de commencer par dasher tous les audits précédents"
GoTo 4
Else: GoTo 3
End If
3
'Set des value HSE
Set plage = Range("D2:D201")
plage.Value = ""
If plage.Count > 201 Then Exit Sub
Randomize
For Each cel In plage
1 alea = WorksheetFunction.RandBetween(1, 201)
If Application.CountIf(plage, alea) Then GoTo 1 Else cel = alea
Next
i = 1
For i = 2 To 201
If Cells(i, 2) = "" Then
Cells(i, 4) = 0
End If
Next
If Range("F1").Value > Range("E1").Value - 22 Then Range("E2:E201").ClearContents
i = 1
For i = 2 To 10
Cells(i, 10) = Cells(i, 9).Value
Next
i = 1
For i = 2 To 10
k = Cells(i, 10).Value + 1
Cells(k, 5) = "x"
Next
'Set des value 5SPS
Set plage = Range("o2:o201")
plage.Value = ""
If plage.Count > 201 Then Exit Sub
Randomize
For Each cel In plage
2 alea2 = WorksheetFunction.RandBetween(1, 201)
If Application.CountIf(plage, alea2) Then GoTo 2 Else cel = alea2
Next
i = 1
For i = 2 To 201
If Cells(i, 13) = "" Then
Cells(i, 15) = 0
End If
Next
If Range("Q1").Value > Range("P1").Value - 22 Then Range("P2:P201").ClearContents
i = 1
For i = 2 To 7
Cells(i, 21) = Cells(i, 20).Value
Next
i = 1
For i = 2 To 7
k = Cells(i, 21).Value + 1
Cells(k, 16) = "x"
Next
'Set des Dash values
Range("AW2") = 1
Range("AW3") = 1
Range("AW4") = 1
4
'pour gagner du temps/off
Application.Calculation = xlAutomatic
'Retour a la page de lancement
ActiveWindow.SelectedSheets.Visible = False
Sheets("Template_Remplissage").Select
Application.ScreenUpdating = True
End SubDim dlg As Integer
Sub dataimplement_matin()
Dim i As Integer
'Désactivation de l'épilespse
Application.ScreenUpdating = False
Sheets("Liste").Visible = True
'vérif de non vide
Sheets("Template_Remplissage").Select
For i = 6 To 11
If Cells(i, 4) = "" Then
MsgBox "merci de ne pas laisser de cases vides"
GoTo 9
Else:
If Cells(i, 4) = "Nok" And Cells(i, 5) = "" Then
MsgBox "une cause et ou une action doit etre renseignée pour chaque Nok"
GoTo 9
End If
End If
Next
For i = 3 To 4
If Cells(i, 2) = "" Then
MsgBox "merci de renseigner le responsable d'audit et/ou la date"
GoTo 9
Else:
End If
Next
'ajout dans database des item tests
Sheets("Liste").Select
Range("AF2:AT2").Select
Selection.Copy
Sheets("Database").Select
Range("G1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=False
'ajout secteur date auditeur
Sheets("Template_Remplissage").Select
Range("$B$3").Select
Selection.Copy
Sheets("Database").Select
Range("E1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Template_Remplissage").Select
Range("$B$4").Select
Selection.Copy
Sheets("Database").Select
Range("B1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D1").Select
Selection.End(xlDown)(2).Select
ActiveCell.Value = Sheets("Liste").Range("AV2").Value
dlg = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & dlg) = dlg - 2
'Remplissage PDCA
'ajout dans PDCA des item concernés par un suivi
Sheets("Template_Remplissage").Select
Range("A6:E11").Select
Selection.Copy
Sheets("PDCA").Select
Range("A1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'suppression des lignes
Range("D1").Select
Selection.AutoFilter
ActiveSheet.Range("A:E").AutoFilter Field:=4, Criteria1:="=NA", _
Operator:=xlOr, Criteria2:="=Ok"
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete
Selection.AutoFilter
'nettoyage commentaire du Template affichage n-1
Sheets("Liste").Select
Range("AW2") = 0
Sheets("Template_Remplissage").Select
Range("B3:C4,D6:E11").ClearContents
'retour a la feuille et réactivation de l'écran
9
Sheets("Liste").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Template_Remplissage").Select
Application.ScreenUpdating = True '
End Sub
Sub dataimplement_aprem()
Dim i As Integer
i = 16
'Désactivation de l'épilespse
Application.ScreenUpdating = False
Sheets("Liste").Visible = True
'vérif de non vide
Sheets("Template_Remplissage").Select
For i = 17 To 22
If Cells(i, 4) = "" Then
MsgBox "merci de ne pas laisser de cases vides"
GoTo 10
Else:
If Cells(i, 4) = "Nok" And Cells(i, 5) = "" Then
MsgBox "une cause et ou une action doit etre renseignée pour chaque Nok"
GoTo 10
End If
End If
Next
For i = 14 To 15
If Cells(i, 2) = "" Then
MsgBox "merci de renseigner le responsable d'audit et/ou la date"
GoTo 10
Else:
End If
Next
'ajout dans database des item tests
Sheets("Liste").Select
Range("AF3:AT3").Select
Selection.Copy
Sheets("Database").Select
Range("G1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=False
'ajout secteur date auditeur
Sheets("Template_Remplissage").Select
Range("$B$14").Select
Selection.Copy
Sheets("Database").Select
Range("E1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Template_Remplissage").Select
Range("$B$15").Select
Selection.Copy
Sheets("Database").Select
Range("B1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D1").Select
Selection.End(xlDown)(2).Select
ActiveCell.Value = Sheets("Liste").Range("AV3").Value
dlg = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & dlg) = dlg - 2
'Remplissage PDCA
'ajout dans PDCA des item concernés par un suivi
Sheets("Template_Remplissage").Select
Range("A17:E22").Select
Selection.Copy
Sheets("PDCA").Select
Range("A1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'suppression des lignes
Range("D1").Select
Selection.AutoFilter
ActiveSheet.Range("A:E").AutoFilter Field:=4, Criteria1:="=NA", _
Operator:=xlOr, Criteria2:="=Ok"
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete
Selection.AutoFilter
'nettoyage commentaire du Template affichage n-1
Sheets("Liste").Select
Range("AW3") = 0
Sheets("Template_Remplissage").Select
Range("B14:C15,D17:E22").ClearContents
'retour a la feuille et réactivation de l'écran
10
Sheets("Liste").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Template_Remplissage").Select
Application.ScreenUpdating = True '
End Sub
Sub dataimplement_nuit()
Dim i As Integer
i = 16
'Désactivation de l'épilespse
Application.ScreenUpdating = False
Sheets("Liste").Visible = True
'vérif de non vide
Sheets("Template_Remplissage").Select
For i = 28 To 33
If Cells(i, 4) = "" Then
MsgBox "merci de ne pas laisser de cases vides"
GoTo 11
Else:
If Cells(i, 4) = "Nok" And Cells(i, 5) = "" Then
MsgBox "une cause et ou une action doit etre renseignée pour chaque Nok"
GoTo 11
End If
End If
Next
For i = 25 To 26
If Cells(i, 2) = "" Then
MsgBox "merci de renseigner le responsable d'audit et/ou la date"
GoTo 11
Else:
End If
Next
'ajout dans database des item tests
Sheets("Liste").Select
Range("AF4:AT4").Select
Selection.Copy
Sheets("Database").Select
Range("G1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=False
'ajout secteur date auditeur
Sheets("Template_Remplissage").Select
Range("$B$25").Select
Selection.Copy
Sheets("Database").Select
Range("E1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Template_Remplissage").Select
Range("$B$26").Select
Selection.Copy
Sheets("Database").Select
Range("B1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D1").Select
Selection.End(xlDown)(2).Select
ActiveCell.Value = Sheets("Liste").Range("AV4").Value
dlg = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & dlg) = dlg - 2
'Remplissage PDCA
'ajout dans PDCA des item concernés par un suivi
Sheets("Template_Remplissage").Select
Range("A28:E33").Select
Selection.Copy
Sheets("PDCA").Select
Range("A1").Select
Selection.End(xlDown)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'suppression des lignes
Range("D1").Select
Selection.AutoFilter
ActiveSheet.Range("A:E").AutoFilter Field:=4, Criteria1:="=NA", _
Operator:=xlOr, Criteria2:="=Ok"
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete
Selection.AutoFilter
'nettoyage commentaire du Template affichage n-1
Sheets("Liste").Select
Range("AW4") = 0
Sheets("Template_Remplissage").Select
Range("B25:C26,D28:E33").Select
Selection.ClearContents
'retour a la feuille et réactivation de l'écran
11
Sheets("Liste").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Template_Remplissage").Select
Application.ScreenUpdating = True '
End Sub