Liaisons entre classeurs

Je te remercie

Je cherche aussi de mon côté

Voici

J'ai testé aussi sur mon réseau la fonction FichierDéjàOuvert .

Ouvre un des fichiers du dossier test avant de lancer la macro.

Option Explicit
Dim chemin$, ligne%

Sub maj()
    chemin = ThisWorkbook.Path & "\test\"
    Sheets("log").Cells.Clear: ligne = 1
    push Sheets("test").Range("B2:D3")
    push Sheets("data").Range("B4:D5")
End Sub

Sub push(plage As Range)
Dim wbk1 As Workbook, wbk2 As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim monFichier As String, feuille As String
    feuille = plage.Parent.Name
    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.Sheets(feuille)
    monFichier = Dir(chemin & "*.xlsx")
    Do While monFichier <> ""
        If monFichier Like "*.xls*" Then
            If FichierDejaOuvert(chemin & monFichier) Then
                wbk1.Sheets("log").Cells(ligne, 1) = """" & monFichier & """ déjà ouvert, transfert impossible !": ligne = ligne + 1
            Else
                Set wbk2 = Workbooks.Open(chemin & monFichier)
                If FeuilleExiste(wbk2, feuille) Then
                    Set ws2 = wbk2.Sheets(feuille)
                    transfert plage, ws1, ws2
                    wbk1.Sheets("log").Cells(ligne, 1) = "Transfert vers """ & monFichier & """ feuille """ & feuille & """ ok !": ligne = ligne + 1
                Else
                    wbk1.Sheets("log").Cells(ligne, 1) = "Feuille """ & feuille & """ de """ & monFichier & """ absente !": ligne = ligne + 1
                End If
                wbk2.Close True
            End If
        End If
        monFichier = Dir
    Loop

End Sub

Sub transfert(plage As Range, ws1 As Worksheet, ws2 As Worksheet)
Dim cel As Range
    For Each cel In plage
        cel.Copy Destination:=ws2.Cells(cel.Row, cel.Column)
    Next
    ' Application.CutCopyMode = False
End Sub

Function FichierDejaOuvert(filename As String) As Boolean
Dim filenum As Integer, Errnum As Integer
    filenum = FreeFile()
    On Error Resume Next
        Open filename For Input Lock Read As #filenum
        Close filenum
    Errnum = Err
    On Error GoTo 0
    Select Case Errnum
        Case 0
            FichierDejaOuvert = False
        Case 70
            FichierDejaOuvert = True
    End Select
End Function

Function FeuilleExiste(wbk As Workbook, sNomFeuille As String) As Boolean
    On Error GoTo Err_FeuilleExiste
    FeuilleExiste = False
    FeuilleExiste = Not wbk.Worksheets(sNomFeuille) Is Nothing
Err_FeuilleExiste:
End Function

Waouaaaaaaah !

J'étais en train de galérer avec un code que j'ai trouvé sur le net....

On voit la différence entre connaisseur et un novice

C'est juste excellent, ce que tu as fait ! MERCI Steelson !

Je continue les tests avec le vrai fichier et je te dis ce qu'il en est

Quelques commentaires quand même :

• Il faudrait à mon sens, quelque soit la solution, inclure un numéro de version ou une date dans les transferts pour bien s'assurer de travailler avec la dernière version, ou tout au moins pouvoir faire référence à "la" version de travail

• On pourrait utiliser un système hybride, par exemple envoyer par push l'info de la version, (voire même du dossier dans lequel la référence est stockée pour permettre un éventuel changement de dossier), et déclencher la mise à jour par appel comme au début du fil en fonction d'un écart de version

Tu as raison

Je mets à jour le fichier de production et testerai cette semaine avec les utilisateurs.

Je te transmettrai en MP la version utilisée pour que tu vois

Attention, si tes classeurs à mettre à jour sont en xlsm, il fat changer la macro (qui prendra en compte les xlsx et xlsm) :

Option Explicit
Dim chemin$

Sub maj()

    chemin = ThisWorkbook.Path & "\test\"

    push Sheets("test").Range("B2:D3")
    push Sheets("data").Range("B4:D5")

End Sub

Sub push(plage As Range)
Dim wbk1 As Workbook, wbk2 As Workbook, ws1 As Worksheet, ws2 As Worksheet, log As Worksheet
Dim monFichier As String, feuille As String

    feuille = plage.Parent.Name
    Set wbk1 = ThisWorkbook
    Set log = wbk1.Sheets("log")
    Set ws1 = wbk1.Sheets(feuille)

    monFichier = Dir(chemin & "*.xls*")
    Do While monFichier <> ""
        If monFichier Like "*.xls*" Then
            If FichierDejaOuvert(chemin & monFichier) Then
                log.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = Now & " : """ & monFichier & """ déjà ouvert, transfert impossible !"
            Else
                Set wbk2 = Workbooks.Open(chemin & monFichier)
                If FeuilleExiste(wbk2, feuille) Then
                    Set ws2 = wbk2.Sheets(feuille)
                    plage.Copy Destination:=ws2.Cells(plage.Row, plage.Column)
                    log.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = Now & " : Transfert vers """ & monFichier & """ feuille """ & feuille & """ ok !"
                Else
                    log.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = Now & " : Feuille """ & feuille & """ de """ & monFichier & """ absente !"
                End If
                wbk2.Close True
            End If
        End If
        monFichier = Dir
    Loop

End Sub

Function FichierDejaOuvert(filename As String) As Boolean
Dim filenum As Integer, Errnum As Integer
    filenum = FreeFile()
    On Error Resume Next
        Open filename For Input Lock Read As #filenum
        Close filenum
    Errnum = Err
    On Error GoTo 0
    Select Case Errnum
        Case 0
            FichierDejaOuvert = False
        Case 70
            FichierDejaOuvert = True
    End Select
End Function

Function FeuilleExiste(wbk As Workbook, sNomFeuille As String) As Boolean
    On Error GoTo Err_FeuilleExiste
    FeuilleExiste = False
    FeuilleExiste = Not wbk.Worksheets(sNomFeuille) Is Nothing
Err_FeuilleExiste:
End Function

Bonsoir Steelson,

Après une longue absence (hospi), je reprends l'avancée de ce projet.

En voulant mettre en place la collecte des données j'obtiens une erreur 1004 à la ligne :

rng2.Offset(1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count).Copy

Je n'arrive pas à débloquer ce problème :

Pourrais-tu m'aider, please?

Les fichiers sont dans le même répertoire que celui récoltant les données.

Pour rappel, voici le code entier :

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range

    Dim chemin$, monFichier$, onglet$

Sub collecter()

    ' à modifier ...
    chemin = ThisWorkbook.Path & "\"
    onglet = "Sauvegarde"

    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.Sheets(onglet)
    ws1.Cells(1).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(chemin & "*.xlsm")

    Do While monFichier <> ""
        If monFichier Like "*.xlsm" Then
            Set wbk2 = Workbooks.Open(chemin & monFichier)
            Set ws2 = wbk2.Sheets(onglet)
            Set rng2 = ws2.Cells(1).CurrentRegion
            rng2.Offset(1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count).Copy
            Set rng1 = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            rng1.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
            wbk2.Close False
        End If
        monFichier = Dir
    Loop

    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

End Sub

Bonjour,

Les fichiers de base sont bien en xlsm ?

If monFichier Like "*.xlsm"

Si c'est le cas, il faut ajouter un test pour exclure le fichier "maître".

Tous les fichiers ont-ils bien un onglet appelé Sauvegarde ?

Pour aller plus loin, il faudrait un jeu de fichiers (j'ai tenté de recréer mais c'est trop long).

J'ai aussi l'impression que ce n'est plus le même sujet !

J'ai réussi à tout faire fonctionner .

Je te remercie pour ton aide