Modifier du code vb dans excel par macro [Résolu]

Signaler
Messages postés
10
Date d'inscription
lundi 27 février 2006
Statut
Membre
Dernière intervention
26 décembre 2006
-
Messages postés
10
Date d'inscription
lundi 27 février 2006
Statut
Membre
Dernière intervention
26 décembre 2006
-
Salut,

je dispose d'une quantité importante de fichier Excel. Dans chacun des fichiers Excel, j'ai écrit en dur, dans du code vb (module), un chemin spécifique vers un répertoire. Ce chemin étant le meme pour tous les fichiers, je voudrais réaliser une macro permettant de modifier pour tous les fichiers, le nouveau chemin, en dur, vers le nouveau répertoire. Je n'arrive pas à résoudre ce problème. Il existe certainement une macro faisant ce travail... Si vous avez une piste, je suis preneur!

Merci

2 réponses

Messages postés
10
Date d'inscription
lundi 27 février 2006
Statut
Membre
Dernière intervention
26 décembre 2006

a partir de ce que j'ai trouvé sur le forum j'ai trouvé une solution à mon pb :

Function sChangeCaractere(ByVal laChaine As String, ByVal old_car As String, ByVal new_car As String) As String
    Dim ncar As Integer, lng As Integer, result As String, txt As String
    
    
    lng = Len(old_car)
    txt = laChaine
    
    If lng <= 0 Then
        sChangeCaractere = txt
        
        Exit Function
    End If
    
    On Error GoTo ErrChangeCaractre
    
    If lng <= 0 Or Len(Trim(txt)) <= 0 Then
        sChangeCaractere = txt
        
        Exit Function
    End If
    
    result = vbNullString
    ncar = InStr(txt, old_car)
    
    Do While ncar
        If Len(result) > 0 Then
            If lng > 1 Then
                If ncar = 1 Then
                    result = result & new_car
                Else
                    result = result & Left(txt, ncar - 1) & new_car
                End If
            Else
                result = result & Left(txt, ncar - 1) & new_car
            End If
        Else
            result = Left(txt, ncar - 1) & new_car
        End If
        
        If lng > 1 Then
            txt = Right(txt, Len(txt) - ncar - (lng - 1))
        Else
            txt = Right(txt, Len(txt) - ncar)
        End If
        
        ncar = InStr(txt, old_car)
    Loop
    
    If Len(txt) > 0 Then result = result & txt
    
    sChangeCaractere = result
    
    Exit Function
    
ErrChangeCaractre:
    sChangeCaractere = result
End Function


Sub parcours_arborescence()
    disque = "C"
   chemin = "c:\temp\toto"
    Set fs = Application.FileSearch
    Set fso = CreateObject("Scripting.FileSystemObject")
With fs
    .LookIn = chemin
    .SearchSubFolders = True
    .Filename = "*.xls"
    If .Execute() > 0 Then
        MsgBox "There were " & .FoundFiles.Count & _
         " file(s) found."
        For i = 1 To .FoundFiles.Count
            Set fic = fso.GetAbsoluteFileName(.FoundFiles(i))
            'MsgBox fso.GetAbsolutePathName(.FoundFiles(i))
       
        Next i
    Else
        MsgBox "There were no files found."
    End If
End With


   
End Sub


 


Sub traite_tous_les_fichier_d_un_dossier()
         disque = "C"
         chemin = "c:\temp\toto"
         fichier_log = chemin & "resultat.log"
         chemin_origine = "T:\toto\tata\titi"
         chemin_nouveau = "c:\temp"


ChDrive (disque)
ChDir (chemin)
Set FSys = CreateObject("Scripting.FileSystemObject")
FSys.DeleteFile (fichier_log)
Set MonFic = FSys.CreateTextFile(fichier_log, False)
If Err.Number = 0 Then


    MonFic.writeLine "Fichiers non traites"


Else
 FSys.DeleteFile (fichier_log)
 Set MonFic = FSys.CreateTextFile(fichier_log, False)
 MonFic.writeLine "Fichiers non traites"
End If




With Application.FileSearch
    Dim fichier_fait As Boolean
    Dim cpt_fait As Long
    Dim cpt_total As Long
    Dim fic As String
    cpt_fait = 0
     '.NewSearch
     .LookIn = chemin
     .SearchSubFolders = True
     '.FileType = msoFileTypeExcelWorkbooks
     .Filename = "*.xls"
         If .Execute > 0 Then
         MsgBox "There were " & .FoundFiles.Count & _
         " file(s) found."
         cpt_total = .FoundFiles.Count
             For i = 1 To .FoundFiles.Count
                   
                    fic = .FoundFiles(i)
                     fichier_fait = False
                     Dim strold As String
                     Dim c_Wks As Workbook
                     Set c_Wks = Workbooks.Open(.FoundFiles(i))
                     'MsgBox c_Wks.Name
                    
                    
                    For j = 1 To Modules.Count
                        With c_Wks.VBProject.VBComponents.Item(j).CodeModule


                      
                        Dim cmpt As Long
                        cmpt = .CountOfLines
                        Dim c_start As Long
 
                       Dim b As Boolean
                       Dim x As Long
                       x = 1
                     
                        b = .Find(chemin_origine, x, 1, -1, -1)
                        If b = True Then
                                Dim temp As String
                                temp = .Lines(x, 1)
                               
                                Dim s_temp As String
                               
                                s_temp = sChangeCaractere(temp, chemin_origine, chemin_nouveau)
                               
                               
                                .ReplaceLine x, s_temp
                                fichier_fait = True
                                cpt_fait = cpt_fait + 1


                        End If
                       End With
                     
                    Next j
                    If Not fichier_fait Then
                        'fic = CStr(FSys.GetAbsoluteFileName(.FoundFiles(i)))
                        MonFic.writeLine (FSys.GetAbsolutePathName(.FoundFiles(i)))
                        'MsgBox FSys.GetAbsolutePathName(.FoundFiles(i))
                    End If
                   
                    c_Wks.Save
                    c_Wks.Close
                    '.FoundFiles.Item(i).Close
             Next i
            
     Else
         MsgBox "Aucun fichier n'a été trouvé."
     End If
End With
MonFic.Close
End Sub
Messages postés
936
Date d'inscription
lundi 19 janvier 2004
Statut
Membre
Dernière intervention
17 mars 2017
4
Salut,
Voilà un code qui te sera utile

' c_Wks      Le classeur qui contient la macro
' MyMacro    Le nom de la macro
' c_Mod      Le nom du module
' Ligne      la première ligne de la macro à modifier
' c_Change   Le nouveau code sous la forme

' Ex: dans la Macro appelante' c_Change "   For i 1 to 100"' c_Change c_Change & vbCrLf & "       Listbox1 "Fichier & i"
' c_Change = c_Change & vbCrLf & "   Next"

Sub ChangeMacro( _
        c_Wks As Workbook, _
        MyMacro As String, _
        c_Mod As String, _
        Ligne As Long, _
        c_Change As String _
        )





Dim c_Start As Long
  ' On va travailler avec le code
  With c_Wks.VBProject.VBComponents(c_Mod).CodeModule
  ' on recherche la position de la première ligne de la macro
    Start = .ProcBodyLine(MyMacro, 0)
  ' on suprime un nombre de ligne
    .DeleteLines Start + Ligne, 1
  ' Et on insère notre code contenu dans c_change
    .InsertLines Start + Ligne, c_Change
  End With
 
End Sub



Cordialement, Jean-Paul  

______________________________________________________________________

Le Savoir n'a de valeur que s'il est partagé