Macro de Job75 pour copier des cellules de fichiers fermés dans un autre fichier

[Christian0258]

Bonsoir à tout le forum,

Après plusieurs recherches, j'ai trouvé un travail de Job75 sur la possibilité de copier la valeur de cellules sur des fichiers fermés sans utiliser la méthode ADO trop compliquée, et qui ne permet pas de travailler sur des fichiers protégés.

Je souhaiterais votre aide pour adapter le code de Job75...

Voir toutes les explications dans fichiers joints... mot passe tablserv1 et 2 (toto)

Merci pour le temps que vous voudrez bien vouloir m'accorder.
Bien à vous,
Christian

 

[job75]

Re : Macro de Job75 pour copier des cellules de fichiers fermés dans un autre fichier

Bonsoir Christian,

Ce n'est pas la macro que tu présentes qui convient ici.

Avec si peu de fichiers (et de petits tableaux à copier) le plus simple est de les ouvrir, de faire du copier-coller et de les fermer.

Ensuite l'année et le mois en colonnes B et C sont sans intérêt, puisque le mois on le connaît (cellule C3) et qu'il serait curieux que les tableaux correspondent à des années différentes.

Il vaut bien mieux mettre en colonne B le nom du fichier copié.

Sub CopierFichiers()
Dim chemin$, F As Worksheet, feuil$, ad$, dest As Range
Dim nlig&, ncol%, fichier$, w As Worksheet
chemin = ThisWorkbook.Path & "\"
Set F = Feuil1 'CodeName de la feuille Tous
feuil = F.[C3]
ad = "I98:AN112" 'sur les fichiers présentés ici
Set dest = F.[D5] 'cellule de destination
nlig = Range(ad).Rows.Count
ncol = Range(ad).Columns.Count + 2
fichier = Dir(chemin & "tablserv*.xlsm*") '1er fichier du dossier
Application.ScreenUpdating = False
On Error Resume Next 'si la feuille n'existe pas
dest(1, -1).Resize(Rows.Count - dest.Row + 1, ncol).Clear 'RAZ
While fichier <> ""
  If fichier <> ThisWorkbook.Name Then 'au cas où...
    With Workbooks.Open(chemin & fichier, Password:="toto")
      Set w = Nothing
      Set w = .Sheets(feuil)
      If w Is Nothing Then
        MsgBox "Pas de feuille '" & feuil & _
          "' dans le fichier '" & fichier & "'..."
      Else
        w.Range(ad).Copy dest 'copie la plage
        With dest(1, -1).Resize(, 2)
          .Merge 'fusionne
          .HorizontalAlignment = xlCenter
          .Interior.ColorIndex = 49 'bleu
          .Font.Bold = True 'gras
          .Font.ColorIndex = 2 'blanc
          .Value = fichier
        End With
        Set dest = dest.Offset(nlig)
      End If
      .Close False 'ferme le fichier
    End With
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
F.Activate
End Sub

Fichiers joints.

Bonne fin de soirée.

 

[Christian0258]

Re : Macro de Job75 pour copier des cellules de fichiers fermés dans un autre fichier

Re, le forum, Job75,

Merci, Job75, pour le beau boulot.

Dis-moi, je souhaiterais copier QUE les valeurs...en effet mes fichiers contiennent des formules et des formats.
Chaque fichier pèse environ 3000 ko....

C'est un peu long à ouvrir et il me demande, à chaque ouverture de mes 7 fichiers, de copier un "nom défini" existant dans ces fichiers.

Peut-on régler ce problème?

Merci encore, Job75.

Bien à toi,
Christian

 

[job75]

Re : Macro de Job75 pour copier des cellules de fichiers fermés dans un autre fichier

Bonjour Christian, le forum,

Si les fichiers à copier ne sont pas protégés on peut utiliser une formule de liaison sans les ouvrir.

La macro est bien sûr nettement plus rapide :

Sub CopierFichiersFermés()
Dim chemin$, w As Worksheet, feuil$, ad$, dest As Range
Dim nlig&, ncol%, fichier$, f$, i%
chemin = ThisWorkbook.Path & "\"
Set w = Feuil1 'CodeName de la feuille Tous
feuil = w.[C3]
ad = "I98:AN112" 'à adapter
Set dest = w.[D5] 'cellule de destination
nlig = Range(ad).Rows.Count
ncol = Range(ad).Columns.Count
ad = Range(ad).Cells(1).Address(0, 0) '1ère cellule
fichier = Dir(chemin & "tablserv_SansMdP*.xlsm") '1er fichier du dossier
Application.ScreenUpdating = False
On Error Resume Next 'si la feuille n'existe pas
dest(1, -1).Resize(Rows.Count - dest.Row + 1, ncol + 2).Clear 'RAZ
While fichier <> ""
  If fichier <> ThisWorkbook.Name Then 'au cas où...
    fichier = Replace(fichier, "'", "''")
    f = "='" & chemin & "[" & fichier & "]" & feuil & "'!" & ad
    dest = f 'pour tester
    If dest.Text = "#REF!" Then
      dest = ""
    Else
      With dest.Resize(nlig, ncol)
        .Formula = f 'copie la formule
        .Value = .Value 'supprime les formules
        .Replace 0, "", xlWhole 'valeurs zéro
        For i = 7 To 10
          .Borders(i).Weight = xlThin
        Next
        .Borders(xlInsideHorizontal).Weight = xlHairline
        .Borders(xlInsideVertical).Weight = xlHairline
        .Columns(1).Borders(xlEdgeRight).Weight = xlThin
        .Columns(2).Resize(, ncol - 1).HorizontalAlignment = xlCenter
      End With
      With dest(1, -1).Resize(, 2)
          .Merge 'fusionne
          .HorizontalAlignment = xlCenter
          .Interior.ColorIndex = 49 'bleu
          .Font.Bold = True 'gras
          .Font.ColorIndex = 2 'blanc
          fichier = Replace(fichier, "''", "'")
          .Value = fichier
      End With
      Set dest = dest.Offset(nlig)
    End If
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
w.Activate
End Sub

Fichiers joints.

Bonne fête de Pâques.

 

[job75]

Re : Macro de Job75 pour copier des cellules de fichiers fermés dans un autre fichier

Re,

Dis-moi, je souhaiterais copier QUE les valeurs...en effet mes fichiers contiennent des formules et des formats.
Chaque fichier pèse environ 3000 ko....

C'est un peu long à ouvrir et il me demande, à chaque ouverture de mes 7 fichiers, de copier un "nom défini" existant dans ces fichiers.

Il faut copier les valeurs mais aussi les formats :

Sub CopierFichiers()
'-----
        w.Range(ad).Copy
        dest.PasteSpecial xlPasteValues 'valeurs
        dest.PasteSpecial xlPasteFormats 'formats
'-----
Application.Goto F.[C3]
End Sub

Fichier (2).

A+

 

[Christian0258]

Re : Macro de Job75 pour copier des cellules de fichiers fermés dans un autre fichier

Re, le forum, Job75,

Absolument parfait, merci beaucoup Job75, pour tout ce gros et beau boulot.

Bien à toi,
Salut l'artiste,
Christian