Remplacer élément dans code VBA

Bonjour à tous!

Savez vous comment faire pour remplacer une partie de code automatiquement? Ci-dessous mon code et la partie que je veux modifier surligné via une cellule dans mon fichier (B1) pour que les utilisateurs n'aient pas besoin d'aller fouiner dans le code

Sub GetSheets()

Path = "Y:\PROJETS\TEST_ABONNEMENTS_ODIGO\16082016\"

Filename = Dir(Path & "*.xls")

Do While Filename <> ""

Workbooks.Open Filename:=Path & Filename, ReadOnly:=True

For Each Sheet In ActiveWorkbook.Sheets

Sheet.Copy After:=ThisWorkbook.Sheets(1)

Next Sheet

Workbooks(Filename).Close

Filename = Dir()

Loop

End Sub

J'ai trouvé ce code en fouinant sur internet mais je ne sais pas comment l'adapter :

Sub RemplacementMotDansProcedure()

'Nécéssite d'activer la référence

'"Visual basic For Application Extensibility 5.3"

'

Dim Ancien As String, Nouveau As String, Cible As String

Dim VBComp As VBComponent

Dim i As Integer

Dim Wb As Workbook

Set Wb = Workbooks("NomClasseur.xls")

Ancien = "Feuil1"

Nouveau = "Feuil3"

For Each VBComp In Wb.VBProject.VBComponents

For i = 1 To VBComp.CodeModule.CountOfLines

Cible = VBComp.CodeModule.Lines(i, 1)

Cible = Replace(Cible, Ancien, Nouveau)

VBComp.CodeModule.ReplaceLine i, Cible

Next i

Next VBComp

End Sub

Merci pour ceux qui voudront bien m’aider.

Cordialement,

Bonjour,

A tester.

Cdlt.

Sub GetSheets()
Dim sPath As String, sFilename As String
Dim wbSource As Workbook
Dim ws As Worksheet, ws2 As Worksheet

    Set wbSource = ThisWorkbook
    Set ws = wb.Worksheets("BOUTONS")

    sPath = ws.Cells(1, 2).Value
    sFilename = Dir(sPath & "*.xls")

    Do While Filename <> ""
        Workbooks.Open Filename:=sPath & sFilename, ReadOnly:=True
        For Each ws2 In ActiveWorkbook.Worksheets
            ws2.Copy After:=wbSource.Worksheets(1)
        Next ws2
        Workbooks(sFilename).Close SaveChanges:=False
        Filename = Dir()
    Loop

    Set ws = Nothing: Set wbSource = Nothing

End Sub

Bonjour Jean-éric,

Merci pour ton aide

J'ai testé et j'ai une erreur d’exécution 424 me renvoyant à cette ligne

Set ws = wb.Worksheets("BOUTONS")

Je ne comprends pas vraiment cette erreur

Re,

Après relecture de la proposition.

Cdlt.

Sub GetSheets()
Dim sPath As String, sFilename As String
Dim wbSource As Workbook
Dim ws As Worksheet, ws2 As Worksheet

    Set wbSource = ThisWorkbook
    Set ws = wbSource.Worksheets("BOUTONS")
    sPath = ws.Cells(1, 2).Value
    sFilename = Dir(sPath & "*.xls")

    Do While Filename <> ""
        Workbooks.Open Filename:=sPath & sFilename, ReadOnly:=True
        For Each ws2 In ActiveWorkbook.Worksheets
            ws2.Copy After:=wbSource.Worksheets(1)
        Next ws2
        Workbooks(sFilename).Close SaveChanges:=False
        Filename = Dir()
    Loop

    Set ws = Nothing: Set wbSource = Nothing

End Sub

re,

j'ai re testé et ça ne fonctionne pas mais par contre j'ai bidouillé un truc et ça fonctionne comme je le souhaite, voici le code :

Sub GetSheets()

Find = Sheets("BOUTONS").Range("D1")

Filename = Dir(Find & "*.xls")

Do While Filename <> ""

Workbooks.Open Filename:=Find & Filename, ReadOnly:=True

For Each Sheet In ActiveWorkbook.Sheets

Sheet.Copy After:=ThisWorkbook.Sheets(1)

Next Sheet

Workbooks(Filename).Close

Filename = Dir()

Loop

End Sub

Merci encore! a bientot !