XL 2019 Résolu - Bug code VBA modifier xxx fichiers en boucle

[arnaudbu]

Bonjour,

J'ai une centaine de fichier à modifier ...

Toujours le même onglet et même plage (colonne L -> AC) dans xxx fichiers à remplacer par les colonnes L -> AP du fichier source

J'ai fait un bout de code mais qui bug sur la fonction PasteSpecial, je pense car il n'y a plus de selection de la source à copier ... Je bug ...

Si vous pouvez m'aiguiller sur une autre façon peut être ?

Merci

Sub Preco_Change()
'Déclaration des variables
Dim myPath As String, myFile As String, mySheet As String, Plg As Range, MSG As Long

myPath = "C:\Users\xx\Desktop\Source"

'Permet de récupérer le nom des fichiers du répertoire et défini l'onglet
myFile = Dir(myPath & "\*.xlsm")
mySheet = "Gamme"

'Données fichier source
With Workbooks("Macro_PrecoFT.xlsm")

    .Sheets("Gamme").Range("L:AP").Copy

End With


Application.AskToUpdateLinks = False

'Boucle sur l'ensemble des fichiers du répertoire
Do While myFile <> ""
    'On appelle la fonction "BookOpen" définie plus bas : elle permet de vérifier si le classeur est ouvert du répertoire. Sinon, cette fonction ouvre le classeur.
    Call BookOpen(myPath & "\" & myFile)
 
    'Avec le classeur ouvert
    With Workbooks(myFile)
    
        With Sheets(mySheet)

        Columns("L:AC").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End With
        
        Application.DisplayAlerts = False
        
        .Save
        .Close
        
    End With
    'Et on passe au suivant
    myFile = Dir()
Loop

Application.DisplayAlerts = True
 
End Sub
 
Function BookOpen(NomFich)


On Error Resume Next
    Workbooks(NomFich).Activate
    If Err <> 0 Then Workbooks.Open Filename:=NomFich
On Error GoTo 0

End Function

 

[Wayki]

Bonjour,
La plage n'est Pas identique.
Essayez en remplaçant columns("L:AC") par Range("L1") peut être.
A +

 

[arnaudbu]

Merci, j'ai cherché et cherché et j'ai pu faire ça qui fonctionne très bien. j'ai du rajouter une condition qui n'ouvre pas mon fichier source et qui détermine le dossier automatiquement, ça évite de changer le dossier source à chaque fois. Environ 10 minutes pour 70 fichiers excel ...

Sub P_Change()
'Déclaration des variables
Dim myPath As String, myFile As String, mySheet As String

'Détermine le dossier actuel
myPath = ActiveWorkbook.Path

'Permet de récupérer le nom des fichiers en *.xl* du répertoire et défini l'onglet
myFile = Dir(myPath & "\*.xl*")
mySheet = "Gamme"

'Boucle sur l'ensemble des fichiers du répertoire

Application.ScreenUpdating = False

Do While myFile <> ""

    'On appelle la fonction "BookOpen" définie plus bas : elle permet de vérifier si le classeur est ouvert du répertoire. Sinon, cette fonction ouvre le classeur.
    Call BookOpen(myPath & "\" & myFile)
    
    If myFile = "Macro_P.xlsm" Then
    
        GoTo Next_Files
        
    End If

    Application.AskToUpdateLinks = False
    
    Workbooks("Macro_P.xlsm").Sheets("Gamme").Range("L:AP").Copy

        Workbooks(myFile).Sheets(mySheet).Columns("L:AC").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        Application.DisplayAlerts = False
        
        Workbooks(myFile).Save
        Workbooks(myFile).Close

Next_Files:
    'Et on passe au suivant
    myFile = Dir()
Loop

Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
 
End Sub
 
Function BookOpen(NomFich)

On Error Resume Next
    Workbooks(NomFich).Activate
    If Err <> 0 Then Workbooks.Open Filename:=NomFich
On Error GoTo 0

End Function

 

[fanch55]

Bonjour, @Wayki a raison
Code proposé :

Sub Preco_Change()
'Déclaration des variables
Dim myPath As String, myFile As String, mySheet As String, Plg As Range, MSG As Long

myPath = "C:\Users\xx\Desktop\Source"

'Permet de récupérer le nom des fichiers du répertoire et défini l'onglet
myFile = Dir(myPath & "\*.xlsm")
mySheet = "Gamme"

'Données fichier source
Set Plg = Workbooks("Macro_PrecoFT.xlsm").Worksheets(mySheet).Range("L:AP")

'Boucle sur l'ensemble des fichiers du répertoire
Application.DisplayAlerts = False
Do While myFile <> ""
    'Avec le classeur ouvert ou qu'on va ouvrir
    With BookOpen(myPath & "\" & myFile)
        Plg.Copy .Worksheets(mySheet).Range("L1")
        .Close True
    End With
    'Et on passe au suivant
    myFile = Dir()
Loop
Application.DisplayAlerts = True
 
End Sub
 
Function BookOpen(NomFich) As Workbook
On Error Resume Next
    Application.AskToUpdateLinks = False
    Workbooks(NomFich).Activate
    If Err <> 0 Then Workbooks.Open Filename:=NomFich
On Error GoTo 0
    Set BookOpen = ActiveWorkbook
End Function