Impossible d'importer un module en VBA

[Arpette]

Bonsoir à toutes et à tous,
j'ai un message d'erreur sur la ligne #Set VBProj = wb.VBProject# Erreur 1004 la méthode a échoué.
PS : je ne vois plus les balises

Voici le code complet :
Sub imp_module()
Dim nf%, fbas$, f$
Dim wb As Workbook
Dim i&
Dim VBProj As Object
Dim oldMod As Object

Rep = "F:\Trames\Module\"
fbas = Rep & "Module3.bas"
Application.ScreenUpdating = False
Application.EnableEvents = False

f = Dir(Rep & "*.xls")
Do While f <> "" 'boucle sur les fichiers du répertoire
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(Rep & f) 'ouvre le fichier
Set VBProj = wb.VBProject
Set oldMod = ActiveWorkbook.VBProject.VBComponents("module3")
ActiveWorkbook.VBProject.VBComponents.Remove oldMod
Application.VBE.ActiveVBProject.VBComponents.Import (fbas)
On Error GoTo 0
Set VBProj = Nothing
Set CodeMod = Nothing
wb.Close True
End If
f = Dir()
Loop

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Merci de votre aide
@+

 

[Arpette]

Les amis, pas d'idée ?

 

[job75]

Bonsoir Arpette,

Les amis, pas d'idée ?

Je vous ai donné 2 solutions, toutes les 2 fonctionnent parfaitement.

Alors que vos codes ne tiennent pas la route.

A vous de choisir.

A+

 

[job75]

Bonjour Arpette, le forum,

Puisque vous voulez le FileSystemObject voici une 3ème solution :

Sub CopierModules()
Dim chemin$, fso As Object, sf As Object, f As Object
chemin = ThisWorkbook.Path & "\" '"F:\Trames\CONTROLES CLIENTS\"
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Application.EnableEvents = False 'si nécessaire
On Error Resume Next
For Each sf In fso.GetFolder(chemin).SubFolders
  For Each f In sf.Files
    If f.Name <> ThisWorkbook.Name And f.Name Like "*.xls" Then
      With Workbooks.Open(f.Path)
        With .VBProject
          .VBComponents.Remove .VBComponents("Module2")
          .VBComponents.Import(chemin & "Module2.txt").Name = "Module2"
          .VBComponents.Remove .VBComponents("Module3")
          .VBComponents.Import(chemin & "Module3.txt").Name = "Module3"
        End With
        .Close True
      End With
    End If
Next f, sf
Application.EnableEvents = True
End Sub

Notez que f.Path donne le chemin d'accès suivi du nom du fichier.

Fichiers et les sous-dossiers zippés joints pour tester.

Bonne journée.

 

[Arpette]

Bonjour Job, le forum,

Un grand merci pour ce code qui fonctionne à merveille.

Bonne journée.

 

[job75]

Re,

Bah en voulant trop simplifier le code j'ai fait une erreur, au lieu de :

        With .VBProject.VBComponents
          .Remove .VBComponents("Module2")
          .Import(chemin & "Module2.txt").Name = "Module2"
          .Remove .VBComponents("Module3")
          .Import(chemin & "Module3.txt").Name = "Module3"
        End With

il faut écrire :

        With .VBProject
          .VBComponents.Remove .VBComponents("Module2")
          .VBComponents.Import(chemin & "Module2.txt").Name = "Module2"
          .VBComponents.Remove .VBComponents("Module3")
          .VBComponents.Import(chemin & "Module3.txt").Name = "Module3"
        End With

Je corrige le post précédent, prenez la bonne macro.

A+

 

[Arpette]

Re,
je viens de m'en apercevoir. Il y a un autre soucis, le code boucle bien sur f mais quand c'est terminé il ne remonte pas sur sf, il repart sur f.
Merci de votre aide,
@+

 

[job75]

Re,

Le code étudie tous les sous-dossiers sf et dans chacun d'eux tous les fichiers f.

Je ne vois pas ce que vous voulez dire, vous ne comprenez pas Next f, sf ?

C'est la même chose que :

  Next f
Next sf

A+

 

[Arpette]

Re,
Oui je comprends bien, mais ce que je veux dire, sf est un dossier qui est dans le chemin et f est un sous dossier de sf dans lequel il y a les fichiers .xls. Dans votre exemple dossier 2 n'est pas un sous dossier de dossier 1 .
En tous les cas merci de votre aide,
@+

 

[job75]

Re,

et f est un sous dossier de sf dans lequel il y a les fichiers .xls.

Pas du tout, f est un fichier quelconque, allez on tire l'échelle.

Bonne fin de soirée.

 

[Arpette]

Bonne fin de soirée

 

[job75]

Bonjour Arpette, le forum,

J'ai vu que vous êtes déçu

Alors si vous voulez traiter toute l'arborescence des sous-dossiers il faut une récursivité :

Dim CheminInitial$, fso As Object 'mémorisation des variables

Sub CopierModules()
CheminInitial = ThisWorkbook.Path & "\" '"F:\Trames\CONTROLES CLIENTS\"
Set fso = CreateObject("Scripting.FileSystemObject")
Copie CheminInitial
End Sub

Sub Copie(chemin$)
Dim sf As Object, f As Object
Application.ScreenUpdating = False
Application.EnableEvents = False 'si nécessaire
On Error Resume Next
For Each sf In fso.GetFolder(chemin).SubFolders
  Copie sf.Path 'récursivité pour traiter l'arborescence
  For Each f In sf.Files
    If f.Name <> ThisWorkbook.Name And f.Name Like "*.xls" Then
      With Workbooks.Open(f.Path)
        With .VBProject
          .VBComponents.Remove .VBComponents("Module2")
          .VBComponents.Import(CheminInitial & "Module2.txt").Name = "Module2"
          .VBComponents.Remove .VBComponents("Module3")
          .VBComponents.Import(CheminInitial & "Module3.txt").Name = "Module3"
        End With
        .Close True
      End With
    End If
Next f, sf
Application.EnableEvents = True
End Sub

Ci-joint les fichiers avec 4 sous-dossiers (8 fichiers étudiés).

Bonne journée.

 

[Arpette]

Bonjour Job, le forum,
Un grand merci Job pour ce code. Cela répond exactement à ce que je voulais.
Bonne soirée à vous
@+

 

[Arpette]

bonsoir Job, le forum,

Avec votre code j'ai pu modifier la totalité des fichiers (3506). j'essaie maintenant sur le même principe d'exécuter le module 3 sur tous les fichiers. J'ai écrit ceci mas cela ne fonctionne pas.

Option Explicit
Dim CheminInitial$, fso As Object 'mémorisation des variables

Sub CopierModules()
CheminInitial = ThisWorkbook.Path & "\" '"F:\Trames\CONTROLES CLIENTS\"
Set fso = CreateObject("Scripting.FileSystemObject")
Copie CheminInitial
End Sub

Sub Copie(chemin$)
Dim sf As Object, f As Object
On Error Resume Next
For Each sf In fso.GetFolder(chemin).SubFolders
  Copie sf.Path 'récursivité pour traiter l'arborescence
  For Each f In sf.Files
  If f.Name <> ThisWorkbook.Name And f.Name Like "*.xls" Then
  Application.ScreenUpdating = False
  Application.EnableEvents = False 'si nécessaire
  With Workbooks.Open(f.Path)
  With .VBProject
  .Application.Run "Module3"
  End With
  .Close True
  End With
  End If
Next f, sf
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Merci de votre aide

@+

 

[job75]

Bonsoir Arpette,

Là vous jouez les apprentis sorciers, un module ne s'exécute pas !!!

Si vous tenez absolument à exécuter l'une des macros (???) dans chaque fichier :

Sub Copie(chemin$)
Dim sf As Object, f As Object
Application.ScreenUpdating = False
Application.EnableEvents = False 'si nécessaire
On Error Resume Next
For Each sf In fso.GetFolder(chemin).SubFolders
  Copie sf.Path 'récursivité pour traiter l'arborescence
  For Each f In sf.Files
    If f.Name <> ThisWorkbook.Name And f.Name Like "*.xls" Then
      With Workbooks.Open(f.Path)
        With .VBProject
          .VBComponents.Remove .VBComponents("Module2")
          .VBComponents.Import(CheminInitial & "Module2.txt").Name = "Module2"
          .VBComponents.Remove .VBComponents("Module3")
          .VBComponents.Import(CheminInitial & "Module3.txt").Name = "Module3"
        End With
        Application.Run "'" & .Name & "'!Salut" '????????????????
        .Close True
      End With
    End If
Next f, sf
Application.EnableEvents = True
End Sub

Bonne nuit.

 

[Arpette]

Bonjour Job, oui je veux exécuter le module 3 de tous les fichiers.
Par contre je ne pas exécuter cette partie du code car déjà fait

With .VBProject
.VBComponents.Remove .VBComponents("Module2")
.VBComponents.Import(CheminInitial & "Module2.txt").Name = "Module2"
.VBComponents.Remove .VBComponents("Module3")
.VBComponents.Import(CheminInitial & "Module3.txt").Name = "Module3"
End With

Merci de votre aide.