Copier la valeur de cellules de fichiers fermés sur un autre fichier

[Testeur]

Bonjour,

J'ai déjà une discussion similaire, mais je dois modifier le programme proposé par job_75 dans cette discussion selon les disposition décrites dans le fichier "bilan".
A chaque BV serait reporté la référence et le blabla3 et les autres informations indiquées ne sont pas obligatoires pour chaque Bv mais on pourrait les reporter sur chaque ligne.

Du coup j'ai mis deux dispositions possibles: bilan et bilan 2.

Merci par avance

 

[job75]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Bonjour Testeur,

Je réitère ma question de ce fil :

https://www.excel-downloads.com/thr...fichiers-fermes-dans-un-autre-fichier.227608/

Pourquoi copier 40 fois les mêmes valeurs 😕

Par ailleurs :

- comment saurez-vous que telle donnée provient de tel fichier ?

- qu'allez-vous faire de ce bilan, qui n'est guère exploitable en l'état ?

Sans réponses valables je n'irai pas plus loin car j'ai horreur des usines à gaz.

A+

 

[Testeur]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Chaque fichier source a une référence unique, c'est ce qui va les différencier dans le fichier de synthèse.
Pour chaque ligne BV dans le fichier source est il possible de ne copier que les lignes remplies ? ça éviterait de copier les 40 lignes.

Cela vous paraît-il clair ? j'espère 🙂

 

[Testeur]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Toutes les lignes BV ne contiennent pas des données. Il y en a au maximum 40.

 

[Testeur]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

J'ai adapté le tableau synthèse, qu'en pensez-vous ?

En fait du coup je suis obligé de passer par deux tableaux de synthèses, le premier venant de la première discussion et celui là qui synthètise les lignes BV par référence.

Chaque fichier a une référence.

 

[job75]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Re,

C'est quand même un peu du genre usine à gaz :

Sub CopierFichiers()
Dim t, chemin$, W As Worksheet, feuil$, lig&, fichier$
Dim F As Worksheet, P As Range, PBV As Range, a(), rc&, cc As Byte, b()
Dim col As Byte, c As Range, n&, i&, j As Byte
t = Timer 'mesure facultative
chemin = ThisWorkbook.Path & "\"
Set W = Feuil1 'CodeName de la feuille Bilan
feuil = "Tableau-Enquete" 'nom à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà ouvert
W.Rows("2:" & W.Rows.Count).Delete 'RAZ
lig = 2
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
While fichier <> ""
  If fichier <> ThisWorkbook.Name Then
    Set F = Workbooks.Open(chemin & fichier).Sheets(feuil) 'ouverture du fichier
    Set P = F.[F26,A26,A30,F30,C40:F40,F45,F46,F51,D94:F94]
    Set PBV = F.[B54:F93]
    ReDim a(1 To P.Count) 'tableau pour accélérer
    rc = PBV.Rows.Count: cc = PBV.Columns.Count
    ReDim b(1 To rc, 1 To cc) 'tableau pour accélérer
    col = 0
    For Each c In P
      col = col + 1
      a(col) = c
    Next
    W.Cells(lig, 1).Resize(, col) = a
    n = 0
    For i = 1 To rc
      If Application.CountA(PBV.Rows(i)) > 1 Then
        n = n + 1
        For j = 1 To cc
          b(n, j) = PBV(i, j)
        Next
      End If
    Next
    If n Then
      W.Cells(lig, col + 1).Resize(n, cc) = b
      W.Cells(lig, 1).Resize(, col).Copy W.Cells(lig, 1).Resize(n, col) 'est-ce nécessaire ???
    End If
    F.Parent.Close False 'fermeture du fichier
    lig = lig + n
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
W.Activate
MsgBox "Durée " & Format(Timer - t, "0.00 \s") 'mesure facultative
End Sub

Fichiers joints à télécharger dans un même dossier (répertoire) vide.

Chez moi, sur Win XP - Excel 2003, 100 fichiers sources sont traités en 19,3 secondes.

A+

 

[Testeur]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Merci beaucoup cela fonctionne, le timer indique 5.70s sous excel 2013 sur 27 fichiers, mais les résultats sont affichés au bout d'au moins 30 secondes.

Est-il possible d'ajouter une condition ? cette condition serait de copier uniquement les lignes BV qui sont remplies ce qui se traduirait dans le fichier source par le fait que les cellules C54, D54, E54, F54 soient remplies et ainsi de suite pour chaque ligne suivante jusqu'à la 93.

 

[job75]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Re,

Est-il possible d'ajouter une condition ? cette condition serait de copier uniquement les lignes BV qui sont remplies(...)

Elle y est, faute de comprendre il suffit de tester et de regarder 🙄

If Application.CountA(PBV.Rows(i)) > 1 Then

A+

 

[Testeur]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Merci c'est parfait,
Désolé c'est ma faute, j'ai oublié d'indiquer que la colonne C54 à c93 est toujours remplie, il ne faisait pas de tri sur la condition. Je voyais les 40 lignes affichées.
J'ai modifié la ligne en mettant
If Application.CountA(PBV.Rows(i)) > 2 Then
et là les lignes "vides" sont enlevées

C'est bien cela ?

Merci encore

 

[Testeur]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Quel gain de temps ! on gagne en efficacité et en productivité. La maîtrise des outils informatiques c'est extraordinaire.

Merci 🙂

 

[job75]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

j'ai oublié d'indiquer que la colonne C54 à c93 est toujours remplie

Il faut toujours que les fichiers de test correspondent à la réalité.

Je suis content que ma solution vous convienne, bonne fin de soirée et à bientôt.

 

[job75]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Bonjour Testeur, le forum,

Ce n'est pas terminé, avec des formules de liaisons, sans ouvrir les fichiers, c'est plus rapide :

Sub CopierFichiers()
Dim t, chemin$, W As Worksheet, feuil$, lig&, fichier$
Dim P As Range, PBV As Range, a(), rc&, cc As Byte, b()
Dim col As Byte, c As Range, formule$, n&, i&, ad$, j As Byte
t = Timer 'mesure facultative
'---préparation---
chemin = ThisWorkbook.Path & "\"
Set W = Feuil1 'CodeName de la feuille Bilan
feuil = "Tableau-Enquete" 'nom à adapter
lig = 2
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
W.Rows("2:" & W.Rows.Count).Delete 'RAZ
Set P = [F26,A26,A30,F30,C40:F40,F45,F46,F51,D94:F94]
Set PBV = [B54:F93]
ReDim a(1 To P.Count) 'tableau pour accélérer
rc = PBV.Rows.Count: cc = PBV.Columns.Count
ReDim b(1 To rc, 1 To cc) 'tableau pour accélérer
'---traitement des fichiers sources---
While fichier <> ""
  If fichier <> ThisWorkbook.Name Then
    fichier = Replace(fichier, "'", "''")
    col = 0
    For Each c In P
      col = col + 1
      formule = "='" & chemin & "[" & fichier & "]" & feuil & "'!" & c.Address
      a(col) = formule
    Next
    W.Cells(lig, 1).Resize(, col) = a
    n = 0
    For i = 1 To rc
      ad = PBV.Rows(i).Address(ReferenceStyle:=xlR1C1)
      formule = "COUNT('" & chemin & "[" & fichier & "]" & feuil & "'!" & ad & ")"
      If ExecuteExcel4Macro(formule) Then 's'il y a au moins 1 nombre
        n = n + 1
        For j = 1 To cc
          formule = "='" & chemin & "[" & fichier & "]" & feuil & "'!" & PBV(i, j).Address
          b(n, j) = formule
        Next
      End If
    Next
    If n Then
      W.Cells(lig, col + 1).Resize(n, cc) = b
      W.Cells(lig, 1).Resize(n, col) = W.Cells(lig, 1).Resize(, col).Value 'nécessaire ???
    End If
    lig = lig + n
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
W.UsedRange = W.UsedRange.Value 'supprime les formules
W.Activate
MsgBox "Durée " & Format(Timer - t, "0.00 \s") 'mesure facultative
End Sub

Fichier (2).

Chez moi 100 fichiers sources sont traités en 8,4 secondes.

Nota 1 : les plages B54:C93 des fichiers sources ne doivent pas contenir de nombres

Nota 2 : dans la feuille "Bilan" la colonne O (Titre15) est au format personnalisé "0000".

A+

 

[job75]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Re,

Je n'avais jamais vu ça !!!

Il faut exécuter 2 fois W.UsedRange = W.UsedRange.Value pour supprimer les formules.

J'ai modifié la macro du post précédent en conséquence.

Quelqu'un aurait-il une explication à ce comportement bizarre ?

A+

 

[job75]

Re : Copier la valeur de cellules de fichiers fermés sur un autre fichier

Re,

J'ai trouvé mon erreur, j'avais déclaré les tableaux a et b As String : a$() et b$().

J'ai re-corrigé la macro du post précédent, et je vais faire la même chose sur l'autre fil.

A+