Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Macro modification fichiers en Masse : erreur Type 13

xadout

XLDnaute Nouveau
Bonjour,

Je suis novis dans la macro excel. On m'a demandé de faire une modification d'une grosse centaine de fichiers excel.
J'esssai d'y passer par macro :
Voici mon code :
VB:
Sub Protection()
MotPasse = "AAAA"
For Each Feuil In Worksheets  ' https://msdn.microsoft.com/fr-fr/library/office/ff840611.aspx
Feuil.Protect Password:=MotPasse, DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True
Next
End Sub


Sub Déprotection()
MotPasse = "AAAA"
For Each Feuil In Worksheets
Feuil.Unprotect MotPasse
Next
End Sub


Sub MRaccourci()
Set scrHst = CreateObject("WScript.Shell")
emplacement = "x:\Raccourcis FP & FD"
Set Raccourci = scrHst.CreateShortcut(emplacement & "\" & ThisWorkbook.Name & ".lnk")
Raccourci.WorkingDirectory = emplacement
Raccourci.TargetPath = ActiveWorkbook.FullName
Raccourci.Save
Set Raccourci = Nothing
Set scrHst = Nothing
  Range("C3").Select
End Sub

' Appel de la fonction
Option Explicit
Public nb As Integer
Sub Appel()
Dim chemin As String
    nb = 0
    chemin = "x:\Informatique"
    Modifier chemin
End Sub


Public Function Modifier(chemin As String)
Dim fs, Rep As Variant, NewRep As String, Nomfich As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Lister = fs.GetFolder(chemin).Files.Count
    Nomfich = Dir(chemin & "\*.xls")
    Do While Nomfich <> ""
        nb = nb + 1
        Workbooks.Open chemin & "\" & Nomfich 'Ouvre fichier'
        Déprotection 'déprotège
        MRaccourci 'crée le raccourcis
        Worksheets("FP JUIN").Range("T49").Value = "" 'Supprime contenu cellule
        Worksheets("MARS").Rows("16").EntireRow.Hidden = False 'Affiche ligne 16 mars
        Worksheets("MARS").Range("C16:AY16").Locked = True 'Verouille ligne 16 mars de C à AY
        Protection
        Nomfich = Dir()
    Loop
    'Pour chaque sous-répertoire, appel récursif de Lister
    For Each Rep In fs.GetFolder(chemin).SubFolders
        NewRep = Lister(Rep.Path)
    Next Rep
End Function

J'ai une erreur d'éxécution de Type 13, incompatilité de type à la ligne
NewRep = Lister(Rep.Path)

NewRep est bien déclaré....
Si quelqu'un à une piste
 

Roland_M

XLDnaute Barbatruc
Bonjour,

effectivement j'étais pas réveillé !

mais l'erreur vient du fait que tu utilises Lister comme un tableau et en plus en alphanumérique
alors que c'est du numérique et ce n'est pas un tableau !
c'est une variable numérique qui représente le nombre de fichiers
Lister = fs.GetFolder(chemin).Files.Count (< = Nbr de Fichiers dans le Rep) exp Lister = 32

ici NewRep = Lister(Rep.Path)
si tu avais réellement une liste des répertoires ce serait
NewRep = Lister(NoIndice)

comme tu pratiques ça ne peut pas fonctionner
si j'ai le temps j'y regarderai

a savoir ici cette remarque 'Pour chaque sous-répertoire, appel récursif de Lister
ce n'est pas du récursif du tout !
récursif(en faisant simple) c'est une macro qui s'appelle elle même !
ici à l'intérieur de cette Sub il y aurait
Public Function Modifier(chemin As String)
. . .
For Each ... sur les sous reps
Modifier Rep
Next
. . .
End Sub

EDIT:
tes fichiers sont dans un seul répertoire ou avec les sous reps ?
car si c'est un seul rep pas besoin de récursif !?

et puis dans ta boucle tu ouvres les fichiers pour modif mais tu ne refermes rien !?

et ceci: Nomfich = Dir(chemin & "\*.xls")
est-ce uniquement xls ?
car ça va boucler sur toutes les extensions xlsm xlsx . . . !
c'est pareil si tu avais mis "*xls*" !
si c'est que les xls il faudra re-tester l'extension !
 
Dernière édition:

Roland_M

XLDnaute Barbatruc
re

voir ton code avec les deux routines !
tu vérifies, puis tu fais un essai en créant un RepTemp avec qq fichiers
et tu me dis quoi !?
 

Pièces jointes

  • Modif_Fichiers.xlsm
    36.8 KB · Affichages: 19

Discussions similaires

Réponses
19
Affichages
2 K
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…