Sujet Précédent Sujet Suivant

Projet Classeur Excel vérouillé ?

BABUDROME Messages postés 151 Date d'inscription lundi 16 janvier 2006 Statut Membre Dernière intervention 19 avril 2016 - 4 sept. 2015 à 09:54
BABUDROME Messages postés 151 Date d'inscription lundi 16 janvier 2006 Statut Membre Dernière intervention 19 avril 2016 - 20 sept. 2015 à 23:04
Bonjour,
Je ne sais ce que j'ai touché dans les options, mais...
_ mes macros se sont plus "modifiable"
_ l'ouverture de VBAProject pour afficher les feuilles de code m'indique que le projet est verrouillé.
Pourquoi ? Que faire ?
Ma sénilité doit s'accroître... Merci d'avance à mes interlocuteurs; Bab

9 réponses

Réponse 1 / 9
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 137
4 sept. 2015 à 11:44
Bonjour,

Tu vas dans l'éditeur:

Outils- Propriétés de VBAProject- Protection-

Tu mets ton mot de passe pour déverouiller.

Si tu ne te souviens pas du mot de passe que tu as mis, nous ne pouvons pas faire grand chose pour toi sur ce site!

Bon courage

0
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 137
4 sept. 2015 à 11:46
il faut lire deverrouiller
0
Réponse 2 / 9
BABUDROME Messages postés 151 Date d'inscription lundi 16 janvier 2006 Statut Membre Dernière intervention 19 avril 2016
14 sept. 2015 à 15:09
Merci, Le Pivert, pour ta réponse.
Quoique mon classeur est perdu (aucune des macros n'est accessibles) même si je ne refais pas, j'aurais tout de même appris beaucoup à dialoguer avec toi et ucfoutu.
Un autre de vos collègues a participé à mon projet, mais son nom (?) est mémorisé dans mes macros perdues, merci aussi à lui, en espérant qu'il se reconnaitra.
A +, bab
0
Réponse 3 / 9
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 137
14 sept. 2015 à 15:24
La dernière solution, c'est OpenOffice.

Mais sans certitude. Tu peux avoir accès à tes macros, il faudra faire des copier coller sur un classeur Excel. C'est du boulot!

Pour télécharger

http://www.commentcamarche.net/download/telecharger-92-openoffice
0
Réponse 4 / 9
ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 211
14 sept. 2015 à 17:23
Bonjour, Babu,
Bon ... je vais essayer (et pense réussir) de te sortir de cette impasse.
Tu vas recevoir (dans ta messagerie privée) une adresse email (la mienne) à laquelle tu vas envoyer, en pièces jointes :
1) une copie de ton classeur enregistrée en xslm
2) une copie de ton classeur enregistrée en xsl
Tu les obtiens en faisant Fichier ==>> en registrer sous ===>> choisir le type de fichier
A plus
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 9
ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 211
Modifié par ucfoutu le 15/09/2015 à 11:01
Bon ...
Je viens de me mettre volontairement dans la même impasse avec un fichier xlsm, puis ai tenté de m'en sortir en trichant allègrement.
Diverses tentatives faites avec un editeur hexadecimal (j'en espérai beaucoup) se sont traduites par un échec.
J'ai alors tenté de harponner la fenêtre demandant le mot de passe et de raconter via cette fenêtre des bobards à Excel ... ====>> waouh ... je suis sorti de l'impasse.
J'attends donc que tu me fasses parvenir par email ton classeur enregistré en .xlsm ....
Je te le retournerai immédiatement, totalement libéré de cette protection.

PS : au passage : je n'ai pas vraiment "forcé" pour violer ainsi cette protection ! Si j'y suis parvenu, il doit probablement exister des milliers de personnes qui auront la même idée. A quoi bon, alors, cette "protection" qui n'est finalement qu'un gadget (puisque violable) ?
Nonobstant, je ne contribuerai pas, en divulguant le code écrit et à partir d'où je l'ai exécuté, à fragiliser encore plus ce genre de protection.
J'attends ton xlsm.


________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.
0
Réponse 6 / 9
ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 211
18 sept. 2015 à 10:45
Bonjour, Babudrome,
J'attends toujours ce fichier !
Je crois utile de te préciser que je n'ai écrit le code à lancer pour déverrouiller ton projet que dans le but de te rendre service.
Ce code, qui m'est personnellement inutile, encombre actuellement mon disque dur.
A défaut d'une réaction de ta part dans la semaine qui vient, je le détruirai donc.
0
Réponse 7 / 9
BABUDROME Messages postés 151 Date d'inscription lundi 16 janvier 2006 Statut Membre Dernière intervention 19 avril 2016
20 sept. 2015 à 07:06
Merci. Je prépare l'envoi.
Absent cette derniers jours, je n'avais pas d'accès à mon PC pour répondre.
A bientôt donc... Babu
0
Réponse 8 / 9
ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 211
Modifié par ucfoutu le 20/09/2015 à 19:05
Bon ...
1) ton classeur n'était pas avec un projet verrouillé (procédure différente de celle envisagée), mais dans une autre situation (classeur partagé et donc avec protection particulière du projet).
2) il m'a donc fallu chercher une autre voie (scabreuse elle aussi) pour y lire ce que je devais y lire (toutes tes macros et procédures) :
Les voilà ci-après :
A/ Module1 : 
 Option Explicit
    Declare Function Beep Lib "kernel32.dll" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
    
    Public Const FeuilMain = "Mes Supports", FeuilDos = "Mes Dossiers", FeuilFic = "Mes Fichiers" ', col1 = -16776961, col2 = -1003520
    Public Const NbFeuilMax = 3000, Abandon = vbCr + "    Annuler ==> Abandon", Sép = "|", Gris = &HC0C0C0, Vert = &H8000&
    Public Const NFic = "Mes Fichiers.TXT", NDos = "Mes Dossiers.TXT", NAide = "Mon Aide.Doc", Coma = ","
    Public i%, R%, C$, Col$, Qot$, QCQ$, Colmoins1$, Caff$, LastArrêt$, Déb%, n As Double, T As Double, TbFeuil(30), iFeuil%, Classeur$, Sauvegarde$
    Public CheminClasseur$, SupportMax%, FFic$, FDos$, FAide, TbDoss$(30000), iDos As Double, iDosMax As Double, LastiDos As Double, iNivoDos%
    Public Vdos As Double, Vfic As Double, NivoMax%, SwPréalable As Boolean
    Public Lg%, Lig%, iFicDos As Double, iFicFic As Double, Vol$(9999), ZFeuilOccupées$, ChoixDoss$, ObjCaché As Boolean ' 3ème arg=0 pour Nb de lignes
'************************************* Variables données Sons ***********************
    Public Const Nsons = "Mes Sons.TXT"
    Global NbSons As Byte, FSons$, SwSons As Boolean
    Global DQues$(4), SonQues%(), iQues As Byte
    Global DErrS$(4), SonErrS%(), iErrS As Byte
    Global DFinL$(4), SonFinL%(), iFinL As Byte
    Global DActi$(4), SonActi%(), iActi As Byte
    Global DTest$(4), SonTest%(2, 4), iTest As Byte
'*********************************************************************
' image 8 = Patience1 : le temps de recherche des supports           *
' image 3 = FinInit   : fin de recherche des supports                *
' image 9 = Patience2 : temps de recherche des niveaux supérieurs    *
' image 4 = FinAnalyse: analyse terminéee                            *
'                                                                    *
' image 5 = pour appel de l'aide                                     *
'*********************************************************************
Sub image4_clic()   ' clic sur l'image [ ? ]
1:  ActiveWorkbook.FollowHyperlink Address:=FAide: End Sub
Sub Bip(Fréq%, Durée%)
    If SwSons Then Beep Fréq, Durée
End Sub
Sub BipErreurSaisie()
    Dim R As Byte: For R = 1 To iErrS: Bip SonErrS(1, R), SonErrS(2, R): Next R: End Sub
Sub BipQuestion()
    Dim R As Byte: For R = 1 To iQues: Bip SonQues(1, R), SonQues(2, R): Next R: End Sub
Sub BipAction()
    Dim R As Byte: For R = 1 To iActi: Bip SonActi(1, R), SonActi(2, R): Next R: End Sub
Sub BipFinLigne()
    Dim R As Byte: For R = 1 To iFinL: Bip SonFinL(1, R), SonFinL(2, R): Next R: End Sub
Sub BipTest()
    Dim R As Byte: For R = 1 To iTest: Bip SonTest(1, R), SonTest(2, R): Next R: End Sub
Sub LireSons()
    Dim i%, x$, k%, D$, L%
    Close: Open FSons For Input As #1: Input #1, x, NbSons  ' lire entête titre
    For i = 1 To NbSons: Input #1, x, k
        If UCase(Left(x, 4)) = "QUES" Then
            iQues = k: ReDim SonQues(2, k): For k = 1 To iQues: Input #1, D
            L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
            SonQues(1, k) = Val(Left(D, L - 1)): SonQues(2, k) = Val(Mid(D, L + 1, 11)): DQues(k) = D: Next k: End If
        If UCase(Left(x, 4)) = "ACTI" Then
            iActi = k: ReDim SonActi(2, k): For k = 1 To iActi: Input #1, D
            L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
            SonActi(1, k) = Val(Left(D, L - 1)): SonActi(2, k) = Val(Mid(D, L + 1, 11)): DActi(k) = D: Next k: End If
        If UCase(Left(x, 4)) = "ERRS" Then
            iErrS = k: ReDim SonErrS(2, k): For k = 1 To iErrS: Input #1, D
            L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
            SonErrS(1, k) = Val(Left(D, L - 1)): SonErrS(2, k) = Val(Mid(D, L + 1, 11)): DErrS(k) = D: Next k: End If
        If UCase(Left(x, 4)) = "FINL" Then
            iFinL = k: ReDim SonFinL(2, k): For k = 1 To iFinL: Input #1, D
            L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
            SonFinL(1, k) = Val(Left(D, L - 1)): SonFinL(2, k) = Val(Mid(D, L + 1, 11)): DFinL(k) = D: Next k: End If
        Next i: Close: End Sub
Sub RewriteSons()
    Dim x$, i%, j%: Close: Open FSons For Output As #4
    Print #4, "Nombre de Sons           ,4"
    x = "Action    ," + Trim(iActi): For i = 1 To iActi: x = x + "," + DActi(i): Next i: Print #4, x
    x = "Queston   ," + Trim(iQues): For i = 1 To iQues: x = x + "," + DQues(i): Next i: Print #4, x
    x = "ErrSaisie ," + Trim(iErrS): For i = 1 To iErrS: x = x + "," + DErrS(i): Next i: Print #4, x
    x = "FinLigne  ," + Trim(iFinL): For i = 1 To iFinL: x = x + "," + DFinL(i): Next i: Print #4, x
    Print #4, "": Close: End Sub


Function ListeAllFeuilles() As String
    Dim x$, i%, s$: s = ""
    For i = 2 To Sheets.Count: x = "E" + Trim(i + 2): s = s + Right(Trim(i + 99), 2) + " " + Sheets(i).Name + vbCr: Next
    ListeAllFeuilles = s: End Function
Function YesOrNo(Tx$) As Boolean
    R = MsgBox(Tx, 4): If R = 6 Then YesOrNo = True Else YesOrNo = False
End Function
Sub Attente(Durée As Double)
    Dim Déb As Double: Déb = Timer: Do While Timer < Déb + Durée: DoEvents: Loop: End Sub
Sub info(Mes$)
    R = MsgBox(Mes, vbOK): End Sub
Sub Protect(ByRef f$, b As Boolean)
    If b Then Worksheets(f).Protect Else Worksheets(f).Unprotect
End Sub
Sub DispAlert(b As Boolean)
    Application.DisplayAlerts = b: End Sub
Sub FixerInfos()
    Application.ScreenUpdating = True: Application.ScreenUpdating = False: End Sub
Public Sub QuitteR()
    Dim x$: x = Range("Classeur").Value: DispAlert False: Workbooks(x).Save
    Sauvegarde = Range("Sauvegarde").Value + x: ActiveWorkbook.SaveCopyAs Sauvegarde: Application.Quit: End Sub
Sub Activer(ByRef f$)
    Sheets(f).Activate: Sheets(f).Select:  ' With ActiveWindow: .Top = 10: .Left = 10: .Width = 1024: .Height = 650: End With
    Protect f, False: Application.ScreenUpdating = False: End Sub
Sub WriteFFic(Donnée$)
    Dim x$: Close
    iFicFic = iFicFic + 1: x = Trim(iFicFic) & Coma & Donnée: Open FFic For Append As #6: Print #6, x: Close: End Sub
Sub WriteFdos(Donnée$)
    Dim x$: Close
    iFicDos = iFicDos + 1: x = Trim(iFicDos) & Coma & Donnée: Open FDos For Append As #6: Print #6, x: Close: End Sub
Sub Trace(x$)
    Debug.Print x: End Sub
Sub VoirIndex()
    Vdos = LireCellule(FeuilDos, "DernièreLigneDos"): Vfic = LireCellule(FeuilFic, "DernièreLigneFic")
    SetCellule FeuilMain, "NbNivReconnus", Trim(iNivoDos): SetCellule FeuilMain, "NbDosReconnus", Trim(Vdos - 1)
    SetCellule FeuilMain, "NbFicReconnus", Trim(Vfic - 1): Range("A1").Select: FixerInfos: End Sub
'************* accès Cellules  *********************************************************
Sub SetCellule(ByVal Feuil$, ByVal NomCellule$, Valeur$)
    On Error GoTo ER: If NomCellule = "" Then Exit Sub
    Protect Feuil, False: Worksheets(Feuil).Activate
    Range(NomCellule).Select: Selection.Value = Valeur: GoTo 9    'FixerInfos:
ER: info "EcrireFeuilDos " & Str(Err) & " " & Error: Resume 9
9:  On Error GoTo 0: End Sub
Function LireCellule(ByVal Feuil$, ByVal NomCellule$) As String
    If NomCellule = "" Then Exit Function
1:  On Error GoTo ER: Activer Feuil: Protect Feuil, False: 'Worksheets(Feuil).Activate
    Range(NomCellule).Select: LireCellule = Selection.Value: GoTo 9
ER: info "LireFeuilDos " & Str(Err) & " " & Error: Resume 1
9:  On Error GoTo 0: End Function

Sub EcrireFeuilDos(Niv%, Nom$, Orig$, Dcréé As Date, Dmodif As Date)
    Dim indx As Double, x$: On Error GoTo ER
    Activer FeuilDos: x = LireCellule(FeuilDos, "DernièreLigneDos"): indx = Val(x) + 1
    x = "A" + Trim(indx): Range(x).Value = Niv:
    x = "B" + Trim(indx): Range(x).Value = Nom:
    x = "C" + Trim(indx): Range(x).Value = Orig:
    x = "D" + Trim(indx): Range(x).Value = Dcréé:
    x = "E" + Trim(indx): Range(x).Value = Dmodif:
    SetCellule FeuilDos, "DernièreLigneDos", Trim(indx): GoTo 9
ER: info "Arrêt Ecriture FeuilDos :" & vbCr & Str(Err) & " " & Error: Resume 9
9:  On Error GoTo 0: Activer FeuilMain: End Sub

Sub EcrireFeuilFic(Niv%, Nom$, Orig$, Dcréé As Date, Dmodif As Date)
    Dim indx As Double, x$: On Error GoTo ER
    Activer FeuilFic: x = LireCellule(FeuilFic, "DernièreLigneFic"):  indx = Val(x) + 1
    x = "A" + Trim(indx): Range(x).Value = Niv:
    x = "B" + Trim(indx): Range(x).Value = Nom:
    x = "C" + Trim(indx): Range(x).Value = Orig:
    x = "D" + Trim(indx): Range(x).Value = Dcréé:
    x = "E" + Trim(indx): Range(x).Value = Dmodif:
    SetCellule FeuilFic, "DernièreLigneFic", Trim(indx): GoTo 9
ER: If Err = 9 Then Resume 9
    info "EcrireFeuilFic " & Str(Err) & " " & Error: Resume 9
9:  On Error GoTo 0: Activer FeuilMain: End Sub

Sub Cherche()
    Dim objFSO, XDrive, XLetter, XName, XFree, XType, XExist, x$, T$, n: On Error GoTo ER
    Activer FeuilMain: Protect FeuilMain, False: Range("ZoneListeFeuilles").ClearContents: Range("ZoneTravail").ClearContents
    Range("ZoneTravail").Select: With Selection.Font: .Color = vbBlack: .Name = "Police corps": .size = 10: .Bold = False: End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each XDrive In objFSO.Drives
        XFree = 0: XExist = objFSO.DriveExists(XDrive): If Not XExist Then GoTo Nxt
        If objFSO.DriveExists(XDrive) Then XLetter = XDrive.DriveLetter: XType = XDrive.DriveType
        i = Asc(XLetter) - 64
        x = "A" + Trim(i): Range(x).Value = XLetter: x = "A" + Trim(i) + ":D" + Trim(i)
        Select Case XType
            Case Is = 1: T = "Clé USB":   Range(x).Font.Color = vbBlue:    XName = XDrive.volumename: XFree = XDrive.FreeSpace
            Case Is = 2: T = "Disc Fixe": Range(x).Font.Color = vbBlack:   XName = XDrive.volumename: XFree = XDrive.FreeSpace
            Case Is = 3: T = "Réseau":    Range(x).Font.Color = vbRed:     XFree = 0: XName = "Réseau"
            Case Is = 4: T = "CD-ROM":    Range(x).Font.Color = Vert:      XFree = 0: XName = "Lecteur CD.ROM"
            Case Is = 5: T = "RAM":       Range(x).Font.Color = vbMagenta: XFree = 0: XName = "Mémoire interne"
            Case Else:   T = "inconnu":   Range(x).Font.Color = Gris:      XFree = 0: XName = "?"
            End Select: x = "D" + Trim(i): Range(x).Value = T
        x = "B" + Trim(i): Range(x).Value = XName
        If XFree > 0 Then
            If XFree > 1024 ^ 3 Then x = "C" + Trim(i): Range(x).Value = Format((Round(XFree / (1024 ^ 3), 1)), "0.0 Go"): GoTo 1
            If XFree > 1024 ^ 2 Then x = "C" + Trim(i): Range(x).Value = Format((Round(XFree / (1024 ^ 2), 1)), "0.0 Mo"): GoTo 1
            If XFree > 1024 ^ 1 Then x = "C" + Trim(i): Range(x).Value = Format((Round(XFree / (1024 ^ 1), 1)), "0.0 Ko")
1:          CréerFeuille (XLetter):    End If
Nxt:    Next: GoTo 9
ER: If Err = 71 Then
        T = "Lecteur Cartes": i = Asc(XLetter) - 64: x = "A" + Trim(i): Range(x).Value = XLetter:
        x = "C" + Trim(i): Range(x).Value = "": x = "D" + Trim(i): Range(x).Value = "Sans carte"
        x = "A" + Trim(i) + ":D" + Trim(i): Range(x).Font.Color = vbRed: Resume Nxt: End If
    info "Erreur sur Recherche " & XLetter & vbCr & "   ER:" & Str(Err) & " " & Error: Resume Nxt
9:  On Error GoTo 0: Set objFSO = Nothing: RecenserFeuilles: Protect FeuilMain, True: iFicDos = 0: LireAllSupports: MarquerFeuilOccupées: End Sub 'iNivoDos = 1:
Sub VoirImage(ByVal NomImage$)
    Const Hau = 370, Lar = 333, Gau = 345: Dim NomIm$: NomIm = UCase(NomImage): Activer FeuilMain
    If NomIm <> "PRÉALABLE" And NomIm <> "PATIENCE1" And NomIm <> "PATIENCE2" And _
    NomIm <> "FININIT" And NomIm <> "FINANALYSE" Then info "Nom IMAGE [" & NomIm & "] inconnu !!!": Exit Sub
    With ActiveSheet.Shapes("image 3"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
    With ActiveSheet.Shapes("image 4"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
    With ActiveSheet.Shapes("image 7"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
    With ActiveSheet.Shapes("image 8"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
    With ActiveSheet.Shapes("image 9"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
    ActiveSheet.Shapes("image 7").Visible = NomIm = "PRÉALABLE":  ActiveSheet.Shapes("image 9").Visible = NomIm = "PATIENCE2"
    ActiveSheet.Shapes("image 8").Visible = NomIm = "PATIENCE1":  ActiveSheet.Shapes("image 3").Visible = NomIm = "FININIT"
    ActiveSheet.Shapes("image 4").Visible = NomIm = "FINANALYSE": End Sub
Sub CheckListeExclusion()
    Dim i%, j%, k%, x$, z$, Sw As Boolean: i = 0: x = UCase(Range("ListExclusion").Value)
1:  z = Right(x, 1): If z <> "\" And z <> "*" And z <> "" Then x = x + "\"  ' contrôle présence de \ ou de * en fin des dossiers à exclute
    Range("ListExclusion").Offset(i, 0).Value = x: i = i + 1: x = UCase(Range("ListExclusion").Offset(i, 0).Value): If x <> "" Then GoTo 1
2:  Sw = False                                                              ' tir par ordre croissant les dossiers à exclure
    For j = 0 To i - 2
        If Range("ListExclusion").Offset(j, 0).Value > Range("ListExclusion").Offset(j + 1, 0).Value Then
            x = Range("ListExclusion").Offset(j, 0).Value
            Range("ListExclusion").Offset(j, 0).Value = Range("ListExclusion").Offset(j + 1, 0).Value
            Range("ListExclusion").Offset(j + 1, 0).Value = x: Sw = True: End If
        Next j: If Sw Then GoTo 2
3:  For j = 0 To i - 2                                                      ' élimine les lignes citant des sous-dossiers alors que le dossier est cité
         x = Range("ListExclusion").Offset(j, 0).Value: z = Range("ListExclusion").Offset(j + 1, 0).Value
         If Left(z, Len(x)) = x Then
            k = j: Sw = True
4:          k = k + 1: Range("ListExclusion").Offset(k, 0).Value = Range("ListExclusion").Offset(k + 1, 0).Value
            If Range("ListExclusion").Offset(k, 0).Value <> "" Then GoTo 4
            End If: Next j: End Sub
Sub Préalable()
    Dim i As Single, j As Single, x$, x1$, x2$, CachePas As Byte, CacheHau As Single, CacheTop As Single: VoirImage "Préalable"
    i = 0: j = 30: SwPréalable = True
    CachePas = 15: CacheHau = 261: CacheTop = 111
    x1 = "ATTENTE de Décision" + vbCr + "après": x2 = " secondes ... " + vbCr + "FERMETURE du classeur !"
    Application.ScreenUpdating = False: Activer FeuilMain: ActiveWindow.DisplayHeadings = False
    With Application: .WindowState = xlNormal: .Height = 648: .Width = 960: .Left = 180: .Top = 12: End With
    With ActiveWorkbook.Windows(1): .DisplayWorkbookTabs = True: .Height = 480: .Zoom = 90: .Width = 940:  End With: P_Init
    With Worksheets(1).Cache: .Height = CacheHau: .Top = CacheTop: .Visible = True: .Value = x1 + Str(j) + x2
1:  SetCellule FeuilMain, "DélaiPréalable", Trim(i):  Application.ScreenUpdating = True
    If i < 30 Then
        DoEvents: Attente 1: i = i + 1: j = 30 - i
        .Value = x1 + Str(j) + x2: CacheTop = CacheTop + CachePas: CacheHau = CacheHau - CachePas
        .Top = CacheTop: .Height = CacheHau: If SwPréalable Then GoTo 1 Else GoTo 2
        End If: .Visible = False: End With: QuitteR: Exit Sub
2:  Worksheets(1).Visible = False: Application.ScreenUpdating = False: End Sub
   ' SetCellule FeuilMain, "DélaiPréalable", ""
Sub P_Init()
    Qot = Chr(34): QCQ = Qot & "," & Qot: Application.ScreenUpdating = True: Application.ScreenUpdating = False
    If Range("Fic_Fichiers").Value = "" Then Range("Fic_Fichiers").Value = FFic
    FFic = Range("Fic_Fichiers").Value: Close: Open FFic For Output As #6
    Print #6, Left("  Noms des fichiers" & Space(40), 40) & Left(" Origine Dossiers" & Space(60), 60) & "  Créé     Modifié  Enreg. "
    Close
    If Range("Fic_Dossiers").Value = "" Then Range("Fic_Dossiers").Value = FDos
    FDos = Range("Fic_Dossiers").Value: Close: Open FDos For Output As #6
    Print #6, Left("  Noms des dossiers" & Space(40), 40) & Left(" Origine Dossiers" & Space(60), 60) & "  Créé     Modifié  Enreg. "
    Close
    If Range("CheminSons").Value = "" Then Range("CheminSons").Value = FSons
    FSons = Range("CheminSons").Value: Close: LireSons: Close
    If Worksheets(1).CheckSons.Value Then Worksheets(1).CheckSons.Caption = "Les Sons sont entendus" Else Worksheets(1).CheckSons.Caption = "Pas de Sons"
    SwSons = Worksheets(1).CheckSons.Value
    If Range("CheminAide").Value = "" Then Range("CheminAide").Value = FAide
    FSons = Range("CheminSons").Value: CheckListeExclusion: initFeuilList FeuilDos: initFeuilList FeuilFic
    Range("Classeur").Value = ThisWorkbook.Name: Range("CheminClasseur").Value = CheminClasseur
    SetCellule FeuilDos, "DernièreLigneDos", "1":  SetCellule FeuilFic, "DernièreLigneFic", "1"
    SetCellule FeuilMain, "CheminSons", FSons:   SetCellule FeuilMain, "NbDosReconnus", "": SetCellule FeuilMain, "Nivatteint", "": End Sub

Sub Initialiser()
1:  P_Init: VoirImage "Patience1": DeleteAllFeuilles: Application.Goto Reference:="R1C1": iNivoDos = 1: Cherche: Application.ScreenUpdating = True: BipAction
    VoirImage "FinInit": End Sub
Sub RecenserFeuilles()
    Dim f$, x$, y$, i%, NbF As Byte, Sw As Boolean
1:  Sw = False
    For i = 4 To Sheets.Count: Sheets(i).Activate: y = ActiveSheet.Name: TbFeuil(i) = y: Next
    For i = 4 To Sheets.Count: y = TbFeuil(i)   ' supprime les feuilles autres que celles des supports
        If Not (Len(y) = 1 Or y = FeuilMain Or y = FeuilDos Or y = FeuilFic) Then
            DispAlert False: Sheets(y).Activate: Sheets(y).Delete: Sw = True: DispAlert True: End If
        Next: If Sw = True Then GoTo 1
    Protect FeuilMain, False: Sheets(FeuilMain).Activate: End Sub
Sub DeleteAllFeuilles()
    Dim f$, i%, j%: On Error GoTo ER: DispAlert False: i = 1
1:  If Sheets.Count > 3 Then
        f = Sheets(i).Name
        If f = FeuilMain Or f = FeuilDos Or f = FeuilFic Then i = i + 1: GoTo 1 'interdit la suppression de feuilles maîtresse
        Sheets(i).Select: ActiveWindow.SelectedSheets.Delete: GoTo 1
        End If: GoTo 9
ER: If Err <> 1004 Then Resume 1        ' Erreur définie par l'application ou par l'objet
9:  On Error GoTo 0: Activer FeuilMain: DispAlert True: End Sub
Sub CréerFeuille(ByRef f$)
    On Error GoTo ER: Activer FeuilMain: DispAlert False
    Sheets.Add after:=Sheets(Sheets.Count): Sheets(Sheets.Count).Name = f: FormaterNewFeuille f: GoTo 9
ER: If Err = 1004 Then Resume Next
    info "CréerFeuille " & Str(Err) & " " & Error: Resume 9
9:  On Error GoTo 0: Activer FeuilMain: End Sub
Sub LireAllSupports()
    Dim i%, j%, k%, x$, y$, z$, Nam$, L$, Nivo As Byte, HeadFeuilSupp$, Chdoss$, N°Support As Byte
    Activer FeuilMain:  Range("ZoneListeFeuilles").ClearContents 'RzTbListe:
    Range("ZoneListeFeuilles").Select
        With Selection.Interior: .Pattern = xlNone: .TintAndShade = 0: .PatternTintAndShade = 0: End With
    Range("ZoneListeFeuilles").Font.Color = vbBlack: Nivo = 1
    For i = 3 To 26: x = "E" + Trim(i): Range(x).Value = "": Next i: k = 3 '<== début liste des supports traités
    For i = 3 To 26: L = Chr(64 + i): N°Support = i
        x = "C" + Trim(i): If Val(Range(x).Value) = 0 Then GoTo Nxt
        x = "A" + Trim(i): L = Range(x).Value:
        x = "B" + Trim(i): Nam = Range(x).Value:
        If Len(L) = 1 Then HeadFeuilSupp = L + ":\":        x = "E" + Trim(k): Range(x).Value = HeadFeuilSupp: k = k + 1
        Activer L: x = "A:E": x = "A1": Range(x).Value = HeadFeuilSupp
        Sheets(L).Select: With ActiveWorkbook.Sheets(L).Tab: .Color = vbBlue: .TintAndShade = 0: End With
        Chdoss = L + ":\": If Not TesTExclusion(Chdoss) Then ExtraireContenuVolume Chdoss
        Activer FeuilMain
Nxt:    Next i: VoirIndex: End Sub
Sub ExtraireContenuVolume(Chdoss$)
    Dim fs, f, f1, fc, sf, Tb%, i%, j%, L%, x$, z$, z2$, Att, Sw As Boolean: On Error GoTo ER0: i = 18 '<== début liste dossiers à exclure
a1: x = "I" + Trim(i): z = Range(x).Value: If z = "" Then GoTo 1
    If Right(z, 1) = "*" Then L = Len(z) - 1: If Left(Chdoss, L) = Left(z, L) Then Exit Sub
    If z = Chdoss Then Exit Sub Else i = i + 1: GoTo a1
1:  Set fs = CreateObject("Scripting.FileSystemObject")
    If Dir(Chdoss$, vbDirectory) = vbNullString Then Exit Sub
    Set f = fs.GetFolder(Chdoss): Set sf = f.SubFolders: On Error GoTo ER1
    For Each f1 In sf:  Att = f1.Attributes: Sw = Att And 6 And ObjCaché: If Sw Then GoTo Nx1
        x = Trim(iNivoDos) & Coma & Qot & Chdoss & f1.Name & "\" & Qot & Coma & vbTab
        If Att And 6 Then GoTo Nx1
2:      iDos = iDos + 1: 'z = Chdoss & f1.Name & "\"
        WriteFdos x & Qot & FormatDate(f1.DateCreated) & QCQ & FormatDate(f1.DateLastModified) & QCQ & FormatDate(Date) & Qot
        EcrireFeuilDos iNivoDos, f1.Name, Chdoss, f1.DateCreated, f1.DateLastModified
Nx1:    Next: LastiDos = iDos:  Set fs = Nothing: On Error GoTo ER2
    Set fs = CreateObject("Scripting.FileSystemObject"):    Set fc = f.Files
    For Each f1 In fc:  Att = f1.Attributes: Sw = Att And 6 And ObjCaché: If Sw Then GoTo Nx2
        x = Trim(iNivoDos) & Coma & f1.Name & Coma & Chdoss & Coma
        If Att And 6 Then GoTo Nx2
        WriteFFic x & FormatDate(f1.DateCreated) & Coma & FormatDate(f1.DateLastModified) & Coma & FormatDate(Date)
        EcrireFeuilFic iNivoDos, f1.Name, Chdoss, f1.DateCreated, f1.DateLastModified
        CopieFeuil Chdoss, f1.Name, FormatDatHeur(f1.DateCreated), FormatDatHeur(f1.DateLastModified), iNivoDos
Nx2:    Next: GoTo 9
ER0: If Err = 5 Or Err = 52 Then GoTo 9           ' Argument ou appel de procédure incorrect
     info "Sur Extraire Contenu : " & vbCr & Chdoss & vbCr & "   ER0 " & Str(Err) & " " & Error: GoTo 9
ER1: If Err = 9 Then Resume Nx1                   ' L'indice n'appartient pas à la sélection
     info "Sur Extraire Contenu : " & vbCr & Chdoss & vbCr & "   ER1 " & Str(Err) & " " & Error: Resume Nx1
ER2: If Err = 5 Then Resume Nx2                   ' Argument ou appel de procédure incorrect
     If Err = 9 Then Resume Nx2                   ' L'indice n'appartient pas à la sélection
     info "Sur Extraire Contenu : " & vbCr & Chdoss & vbCr & "   ER2 " & Str(Err) & " " & Error: Resume Nx2
9:  On Error GoTo 0: SetCellule FeuilMain, "NbDosReconnus", Trim(LastiDos - 1): Set fs = Nothing: End Sub ' z
Function FormatDate(dat As Date) As String
    FormatDate = Format(dat, "dd/mm/yy"): End Function
Function FormatDatHeur(dat As Date) As String
    FormatDatHeur = Format(dat, "dd/mm/yy hh:mm:ss"): End Function
Sub CopieFeuil(Doss$, Fich$, Dcré$, Dmod$, Niv%)
   ' Debug.Print Doss, Fich, Dcré, Dmod, Niv
    Dim Lettre$, x$, DerLig%: Lettre = Left(Doss, 1) ': Debug.Print Lettre; " "; Doss; " | "; Fich; " "; Dcré; " "; Dmod; " "; Trim(Niv)
    Activer Lettre: DerLig = LireCellule(Lettre, "F2") + 1: SetCellule Lettre, "F2", Trim(DerLig)
    x = "A" + Trim(DerLig): SetCellule Lettre, x, Doss
    x = "B" + Trim(DerLig): SetCellule Lettre, x, Fich
    x = "C" + Trim(DerLig): SetCellule Lettre, x, Dcré
    x = "D" + Trim(DerLig): SetCellule Lettre, x, Dmod
    x = "E" + Trim(DerLig): SetCellule Lettre, x, Trim(Niv)
    
End Sub
Sub AppelDossiers()
    Dim i%, j%, iNiv%, Niv%, n%, Chdoss$, OldiDos As Double, ADos As Double, D1$, D2$, D3$
    NivoMax = Val(LireCellule(FeuilMain, "NivoMaxi"))
    On Error GoTo ER:  iNiv = iNivoDos: iDos = 1: VoirImage "Patience2"
1:  Open FDos For Input As #5: Input #5, Chdoss                                     ' lecture première ligne (titres sans virgule)
    OldiDos = LastiDos: ADos = 0: Chdoss = ""
2:  If EOF(5) Then GoTo 6
    DoEvents
    Input #5, n, Niv, Chdoss, D1, D2, D3:    If Niv < iNiv Then GoTo 2              ' saute les dossiers de niveau déjà traités
4:  If TesTExclusion(Chdoss) Then GoTo 5
    ADos = ADos + 1: TbDoss(ADos) = Chdoss:                                         ' stocke les dossiers du niveau donné et non exclus
5:  If EOF(5) Then GoTo 6
    DoEvents
    Input #5, n, Niv, Chdoss, D1, D2, D3: If Niv = iNiv Then GoTo 4
6:  Close: VoirIndex: For i = 1 To iNiv: BipFinLigne: Next: If ADos = 0 Then SetCellule FeuilMain, "Nivatteint", "niveau maxi atteint : " & Trim(iNiv - 1): GoTo 7
    iNiv = iNiv + 1: iNivoDos = iNiv: If iNiv > NivoMax Then SetCellule FeuilMain, "Nivatteint", "Niveau " & Trim(iNiv - 1) & " demandé atteint ": GoTo 7
    For i = 1 To ADos: Chdoss = TbDoss(i): DoEvents
        ExtraireContenuVolume Chdoss: Next                                          ' recherche dossiers du niveau en cours
    LastiDos = iFicDos:  GoTo 1
7:  On Error GoTo 0: TriDonnéesRecensées: VoirImage "FinAnalyse": BipAction: Exit Sub
ER: If Err = 62 Then Resume Next
    info "Sur Appel Dossier : " & vbCr & Chdoss & vbCr & " ER:" & Str(Err) & " " & Error: Resume Next
End Sub
Function TesTExclusion(Doss$) As Boolean
    Dim i%, x$, L%: x = Range("ListExclusion").Value: L = Len(x)
1:  If Right(x, 1) = "*" Then L = L - 1
    If UCase(Left(x, L)) = UCase(Left(Doss, L)) Then TesTExclusion = True: Exit Function
    i = i + 1: x = Range("ListExclusion").Offset(i, 0).Value: L = Len(x): If L > 0 Then GoTo 1
End Function
Sub TriDonnéesRecensées()
    Sheets(FeuilDos).Select
    Application.Goto Reference:="ZTriDos"
    ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, _
                                        Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(FeuilDos).Sort
        .SetRange Range("A2:E78000"):  .Header = xlNo:         .MatchCase = False
        .Orientation = xlTopToBottom:  .SortMethod = xlPinYin: .Apply:    End With
    ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Add Key:=Range("B2:B78000"), SortOn:=xlSortOnValues, _
                                        Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(FeuilDos).Sort
        .SetRange Range("A1:E78000"):  .Header = xlYes:        .MatchCase = False
        .Orientation = xlTopToBottom:  .SortMethod = xlPinYin: .Apply:    End With
    ActiveWindow.ScrollRow = 1
    
    Sheets(FeuilFic).Select
    Application.Goto Reference:="ZTriFic"
    ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Add Key:=Range("B2:B88709"), SortOn:=xlSortOnValues, _
                                        Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(FeuilFic).Sort
        .SetRange Range("A1:E88709"):  .Header = xlYes:        .MatchCase = False
        .Orientation = xlTopToBottom:  .SortMethod = xlPinYin: .Apply:    End With
    ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Add Key:=Range("B2:B88709"), SortOn:=xlSortOnValues, _
                                        Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(FeuilFic).Sort
        .SetRange Range("A1:E88709"):  .Header = xlYes:        .MatchCase = False
        .Orientation = xlTopToBottom:  .SortMethod = xlPinYin: .Apply:    End With
    ActiveWindow.ScrollRow = 1
    Sheets(FeuilMain).Select
End Sub

------------------------------------------------------------------------

B/ Module2 : 
Option Explicit

Function ChercheIndexSheets(f$) As Integer ' donne l'index de la feuille (0 si non trouvée)
    Dim i%: ChercheIndexSheets = 0
    For i = 2 To Sheets.Count: If UCase(f) = UCase(Sheets(i).Name) Then ChercheIndexSheets = i: Exit Function
        Next: End Function
Sub MarquerFeuilOccupées()
    Dim i%, x$, y$: Protect FeuilMain, False: Range("E3:E995").Select
    With Selection.Interior: .Pattern = xlNone: .TintAndShade = 0: .PatternTintAndShade = 0: End With
    ZFeuilOccupées = "E3:E" + Trim(Sheets.Count - 1): Range(ZFeuilOccupées).Select
    With Selection.Interior: .Pattern = xlSolid: .PatternColorIndex = xlAutomatic: .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.799981688894314: .PatternTintAndShade = 0:  End With
    For i = 4 To Sheets.Count: x = "E" + Trim(i - 1): y = Right(Trim(i + 97), 2) + " " + Sheets(i).Name: Range(x).Value = y: Next: End Sub
Sub FormaterNewFeuille(f$)      ' met en forme les feuilles de niveau 1
    Dim x$, i%: x = f + "\"
    Range("A:G").ClearContents: Range("A:G").Select: Selection.RowHeight = 14
    With Selection.Font
        .Name = "Police corps": .size = 10:           .TintAndShade = 0:     .Strikethrough = False:
        .Superscript = False:   .Subscript = False:   .OutlineFont = False:  .Shadow = False
        .Underline = xlUnderlineStyleNone:            .ThemeFont = xlThemeFontNone: End With
    Columns("A:B").Select: Selection.ColumnWidth = 30: Selection.HorizontalAlignment = xlLeft
    Columns("C:D").Select: Selection.ColumnWidth = 6:  Selection.HorizontalAlignment = xlCenter
    Columns("E").Select:   Selection.ColumnWidth = 2:  Selection.HorizontalAlignment = xlCenter
    Columns("F").Select:   Selection.ColumnWidth = 3:  Selection.HorizontalAlignment = xlCenter
  
    Range("A1:B1").Select
        With Selection
            .HorizontalAlignment = xlCenter: .WrapText = False:  .Orientation = 0:    .IndentLevel = 0
            .VerticalAlignment = xlCenter:   .AddIndent = False: .MergeCells = False: .ShrinkToFit = False
            .ReadingOrder = xlContext:       .Value = x: .Font.size = 16:  End With
        With Selection.Interior
            .Pattern = xlNone: .TintAndShade = 0: .PatternTintAndShade = 0: End With
        Sheets(f).Select: With ActiveWorkbook.Sheets(f).Tab: .Color = xlAutomatic: .TintAndShade = 0: End With
    Range("A1").Font.Color = vbBlue
    Columns("C:D").Select: Selection.NumberFormat = "dd/mm/yy hh:mm:ss"
    Range("C1:D1").Select
        With Selection
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = False: .Orientation = 0: .Merge: .ColumnWidth = 10
            .AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False: End With
        ActiveCell.FormulaR1C1 = "Dates" & Chr(10) & "   Création           Modification"
        With ActiveCell.Characters(Start:=1, Length:=29).Font:  .Name = "Police corps": .FontStyle = "Normal": .size = 10
            .Strikethrough = False: .Superscript = False: .Subscript = False: .OutlineFont = False: .Shadow = False: .Underline = xlUnderlineStyleNone
            .ThemeColor = xlThemeColorLight1: .TintAndShade = 0: .ThemeFont = xlThemeFontNone: End With
        With Selection: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = True: .Orientation = 0: .AddIndent = False
            .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = True:  End With
        Selection.Font.Bold = True:    Selection.RowHeight = 30
    Range("F1").Select: Selection.Value = ChercheIndexSheets(f): Selection.VerticalAlignment = xlTop
    Range("F2").Value = 1: Range("G2").Value = "'<== der. ligne"
    Range("G1").Select
        With Selection
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlTop: .WrapText = False: .Orientation = 0
            .AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False
            .Font.Bold = True:  .ColumnWidth = 5: End With
        ActiveCell.FormulaR1C1 = "<== Rang" & Chr(10) & "feuille"
    Range("B1").Select
        With Selection
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = False: .Orientation = 0: .Merge
            .AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False
            .Font.Bold = True:  .Font.size = 10:  .ColumnWidth = 30: End With
        ActiveCell.FormulaR1C1 = "'            dossiers | fichiers ¯¯¯¯¯¯¯¯¯|" & vbCrLf & "<-----/¯¯¯¯¯¯¯¯¯¯¯¯¯                             v   ."
    Range("E1").Select
        With Selection
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = False: .Orientation = 0: .Merge: .ColumnWidth = 2
            .AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False: .Font.Bold = True: End With
        ActiveCell.FormulaR1C1 = "Niv-" & Chr(10) & "eau"
    Range("A1:E1").Select
        With Selection.Interior
            .Pattern = xlSolid: .PatternColorIndex = xlAutomatic: .Color = 65535
            .TintAndShade = 0:  .PatternTintAndShade = 0: End With
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft):         .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
        With Selection.Borders(xlEdgeTop):          .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
        With Selection.Borders(xlEdgeBottom):       .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
        With Selection.Borders(xlEdgeRight):        .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
        With Selection.Borders(xlInsideVertical):   .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
        With Selection.Borders(xlInsideHorizontal): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
    Range("A2").Select: End Sub
Sub initFeuilList(ByRef f$)
    On Error GoTo ER: Activer f
    Cells.ClearContents
  '  Cells.Select.Font.size = 8
  '  Range("A1:L1").Select.Font.size = 10
    Columns("F:F").ColumnWidth = 3.4
    Range("F2").Select:    With Selection
        .HorizontalAlignment = xlCenter:  .VerticalAlignment = xlBottom: .WrapText = False
        .Orientation = 0:  .AddIndent = False:  .IndentLevel = 0: .ShrinkToFit = False
        .ReadingOrder = xlContext:  .MergeCells = False:    End With
 If f = FeuilDos Then
    Range("B1").Value = "Noms des Dossiers": Range("C1").Value = "Origines du dossier"
    Else
    Range("B1").Value = "Noms des Fichiers": Range("C1").Value = "Origines du fichier"
    End If
    Range("A1").Value = "Niv- eau":   Range("D1").Value = "Dates création"
    Range("F1").Value = "Der. ligne": Range("E1").Value = "Dates modif."
    Range("F2").Value = 0
    Application.DisplayFormulaBar = False: ActiveWindow.DisplayHeadings = False: GoTo 9
ER: info "Sur init.FeuilList " & f & vbCr & " ER:" & Str(Err) & " " & Error: Resume Next
9:  On Error GoTo 0: End Sub


C/ Module 3 : 
Option Explicit

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("K19").Select
    Sheets("Mes Supports").Select
    Range("A9").Select
End Sub
</code)
-------------------------------------------------------------
D/ TES FEUILLES :
feuil10(mes fichiers) :
<code>Option Explicit

Private Sub CmdRetourMain_Click()
    Activer FeuilMain: End Sub

</code>
----------------------------------------------------------------

Feuil9(Mes Dossiers) : 
Option Explicit

Private Sub CmdRetour_Click()
    Activer FeuilMain: End Sub

--------------------------------------------------------
Sheet1(Mes Supports) : 
Option Explicit

Private Sub Cache_Change()
    SwPréalable = False: End Sub
Private Sub CheckSons_Click()
    SwPréalable = False
    If CheckSons.Value Then CheckSons.Caption = "Les Sons sont entendus" Else CheckSons.Caption = "Pas de Sons"
    SwSons = CheckSons.Value: End Sub
Private Sub CmdVoirDos_Click()
    SwPréalable = False: Activer FeuilDos: End Sub
Private Sub CmdVoirFic_Click()
    SwPréalable = False: Activer FeuilFic: End Sub
Private Sub CmdLireAutresDossiers_Click()
    SwPréalable = False:  AppelDossiers:     End Sub
Private Sub CmdPréalable_Click()
    SwPréalable = False: End Sub
Private Sub CmdAnalyseSupports_Click()
    SwPréalable = False
1:  ObjCaché = CheckBox2.Value: SwSons = CheckSons.Value: If Not ObjCaché Then GoTo 1
2:  Initialiser: End Sub
Private Sub CheckBox2_Click()
    SwPréalable = False
    If CheckBox2.Value Then CheckBox2.Caption = "Les éléments cachés le restent " Else CheckBox2.Caption = "Les éléments cachés sont vus"
    ObjCaché = CheckBox2.Value:
    End Sub
Private Sub CmdTestSons_Click()
    SwPréalable = False
    Dim i As Byte, j As Byte, k As Byte, L As Byte, n(4) As Byte, iSon As Byte, Fr%, Du%, x$(4), y$, s$
    For i = 1 To 4: x(i) = "": Next i
    y = "Pour chacun des 4 types de sons, chaque note est" + vbCrLf + " définie par sa fréquence =>'1500_50'<= et sa durée. " + vbCrLf + vbCrLf
    j = iActi: n(1) = j: y = y + "1) Attente Action" + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
    For i = 1 To j: x(1) = x(1) + Trim(SonActi(1, i)) + "_" + Trim(SonActi(2, i)) + vbTab: Next i
    j = iQues: n(2) = j: y = y + x(1) + vbCrLf + "2) Question (?)  " + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
    For i = 1 To j: x(2) = x(2) + Trim(SonQues(1, i)) + "_" + Trim(SonQues(2, i)) + vbTab: Next i
    j = iFinL: n(3) = j: y = y + x(2) + vbCrLf + "3) Fin Saisie  " + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
    For i = 1 To j: x(3) = x(3) + Trim(SonFinL(1, i)) + "_" + Trim(SonFinL(2, i)) + vbTab: Next i
    j = iErrS: n(4) = j: y = y + x(3) + vbCrLf + "4) Erreur  " + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
    For i = 1 To j: x(4) = x(4) + Trim(SonErrS(1, i)) + "_" + Trim(SonErrS(2, i)) + vbTab: Next i
                         y = y + x(4) + vbCrLf + "Quel Son (de 1 à 4) faut-il tester ?" + vbCrLf + Abandon
1:  i = Val(InputBox(y, "Ecoute / Echange Sons")): If i = 0 Then Exit Sub
    If i < 1 Or i > NbSons Then GoTo 1 Else iSon = i
    Select Case iSon
        Case Is = 1: BipAction:        s = "Action "
        Case Is = 2: BipQuestion:      s = "Question "
        Case Is = 3: BipFinLigne:      s = "FinSaisie "
        Case Is = 4: BipErreurSaisie:  s = "Erreur "
        End Select
    If Not YesOrNo("Faut-il changer ce son [" + s + "] ?") Then GoTo 1
2:  j = Val(InputBox("Combieb de notes pour [" + s + "] ?" + vbCrLf + _
        Trim(n(i)) + " note(s) actuelle(s)" + vbCrLf + vbTab + "Réponse de 1 à 4" + vbCrLf + Abandon, "Saisie Nb. de notes", Trim(n(i))))
    If j = 0 Then Exit Sub
    If j < 1 Or j > 4 Then GoTo 2 Else iTest = j
3:  For k = 1 To iTest
4:      y = InputBox("Saisir la note N°" + Trim(k) + vbCrLf + " (fréqence et durée sous la forme 99999_9999)" + vbCrLf + _
                     x(i) + vbCrLf + Abandon, "Saisie Fréq._Durée", x(i))
        If Len(y) = 0 Then Exit Sub
        L = InStr(y, "_"): Fr = Left(y, L - 1): Du = Mid(y, L + 1, 11): Bip Fr, Du
        If Not YesOrNo("Est-ce corect ?") Then GoTo 4
        DTest(k) = y: SonTest(1, k) = Fr: SonTest(2, k) = Du: Next k
     For j = 1 To 4: BipTest: Attente 0.4: Next j
     If Not YesOrNo("Est-ce un son acceptable ?") Then GoTo 3
 ' recopie nouveau son (Test) to ancien
    Select Case iSon
        Case Is = 1: iActi = iTest
                     For j = 1 To iTest: DActi(j) = DTest(j): SonActi(1, j) = SonTest(1, j): SonActi(2, j) = SonTest(2, j): Next j
        Case Is = 2: iQues = iTest
                     For j = 1 To iTest: DQues(j) = DTest(j): SonQues(1, j) = SonTest(1, j): SonQues(2, j) = SonTest(2, j): Next j
        Case Is = 3: iFinL = iTest
                     For j = 1 To iTest: DFinL(j) = DTest(j): SonFinL(1, j) = SonTest(1, j): SonFinL(2, j) = SonTest(2, j): Next j
        Case Is = 4: iErrS = iTest
                     For j = 1 To iTest: DErrS(j) = DTest(j): SonErrS(1, j) = SonTest(1, j): SonErrS(2, j) = SonTest(2, j): Next j
        End Select: RewriteSons: End Sub


Aucune de tes autres feuilles ne contient du code autre que Option Explicit
--------------------------------------------------
E/ THISWORKBOOK : 


Option Explicit
Private Sub Workbook_Open()
    Application.DisplayFormulaBar = True: ActiveWindow.DisplayHeadings = True: SwPréalable = False
    FFic = Path + "\" + NFic: FDos = Path + "\" + NDos: FSons = Path + "\" + Nsons: FAide = Path + "\" + NAide
    CheminClasseur = Path + "\" + Name: Activer FeuilMain: Range("CheminClasseur").Value = CheminClasseur: Range("CheminAide").Value = "":
    Range("Fic_Fichiers").Value = "": Range("Fic_Dossiers").Value = "": Range("CheminSons").Value = "": Préalable: End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    QuitteR
End Sub


Que faire avec cela ? ===>>W>
Crée donc un NOUVEAU CLASSEUR (important)
Copie/colle tes feuilles depuis ton fichier xlt (sans les macros)
Réinsère toutes ces procédures et macros dans le nouveau classeur
Sauvegarde (important, bien sûr)

EDIT : Pour tout dire, je ne sais pas ce qu'il s'est passé avec ton classeur (ce qui a provoqué cet incident) : Il contenait un "drapeau" de partage que l'on ne pouvait ôter ni normalement (en départageant) ni depuis une instruction externe sur ce classeur (objet_classeur.UnprotectSharing)
On dirait que ce "drapeau" est anormalement resté là à la suite d'une interruption brutale, alors que le fichier était utilisé depuis ailleurs !)

Bon ... la "chose" devrait maintenant avoir été réglée. Confirme-le moi de sorte à ce que j'efface maintenant tout cela sur mon disque dur.

________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.
0
Réponse 9 / 9
BABUDROME Messages postés 151 Date d'inscription lundi 16 janvier 2006 Statut Membre Dernière intervention 19 avril 2016
20 sept. 2015 à 23:04
Bien reçu toutes mes macros.
Je m'y attelle demain et pense que tu peux effacer la partie que je devais occuper sur ton disque dur.
J'ai déjà copier ces macros dans un texte.

Je te remercie encore pour ta grande attention à mon besoin et surtout ton efficacité. Dès réparation terminée, je t'enverrai un bilan de mon opération réparatrice.
A +, Babu
0

Discussions similaires

Comment fonctionne la fonction FormulaR1C1
cs_razmokets -
wape -

2 réponses
fonction modulo en VBA
krisprolss -
Benouille -

2 réponses
suvi de l'etat d'avancement d'un projet
sanaaSooma -
sanaaSooma -

6 réponses
Exemple des projets ou des minis projets en php/POO
abdeslam2009 -
abdeslam2009 -

2 réponses
Rapport de projet BTS IRIS
chooloveloo -
assala -

4 réponses
Rejoignez-nous