aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme reperto

floR54 · 1 Septembre 2010

Bonjour à TOUS,

Je cherche un code en VBA pour une macro pour mon travail.

J’ai un répertoire avec plusieurs classeurs excel. Chaque classeur à un nom différent mais la forme du fichier est le même pour tous (un tableau dans lequel je rentre mes informations).

J’aimerais, à partir d’un classeur « recap », récupérer les cellules C6, C81 et C83 de chaque classeur de ce répertoire sans les ouvrir. Ce qui serait génial c’est d’avoir les 3 données de ces 3 cellules, les unes en dessous des autres (donc 3 colonnes et autant de lignes que de classeurs dans le répertoire).

Je n’ai pas de connaissance en VBA et cherche tant bien que mal à comprendre sur les forum comment cela marche. A chaque fois que je teste un code, il y a toujours quelques choses qui ne va pas.

Je serais très reconnaissant aux personnes qui voudront bien m’aider !!

Merci à TOUS

job75 · 20 Juillet 2023

Bonjour Patrick,

En fait on peut différencier en ajoutant un test dans la formule :

VB:

Sub Copie()
Dim lig As Integer, p As String, nomfich As String, f As String
Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
Range("A2:D65536").ClearContents 'efface la plage de restitution
lig = 2 'restitution à partir de la ligne 2 (si titres en ligne 1)
p = ThisWorkbook.Path & "\"
nomfich = Dir(p & "*.xls") '1er fichier du dossier
While nomfich <> ""
  If nomfich <> ThisWorkbook.Name Then
    Cells(lig, 1) = nomfich 'nom du fichier en colonne A
    f = "'" & p & "[" & nomfich & "]Feuil1'!C6" 'Feuil1 => nom de la feuille à adapter...
    Cells(lig, 2).Formula = "=IF(" & f & "="""",""""," & f & ")"
    f = "'" & p & "[" & nomfich & "]Feuil1'!C81"
    Cells(lig, 3).Formula = "=IF(" & f & "="""",""""," & f & ")"
    f = "'" & p & "[" & nomfich & "]Feuil1'!C83"
    Cells(lig, 4).Formula = "=IF(" & f & "="""",""""," & f & ")"
    Cells(lig, 2).Resize(, 3) = Cells(lig, 2).Resize(, 3).Value 'facultatif, si l'on veut supprimer les formules
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
End Sub

A+

patricktoulon · 20 Juillet 2023

Bonjour @job75
ok donc le zero est appliqué dans la cellule si la valeur est vide et non dans la variable f
c'est bon a savoir merci

job75 · 20 Juillet 2023

Le zéro est renvoyé uniquement quand la cellule contient zéro.

patricktoulon · 20 Juillet 2023

re
oui j'avais compris
ce que je voulais dire c'est
quand on fait pas le test la formule renvoie vide mais en l'appliquant à la cellule le zéro apparait
le value est donc un long (by default)

Pierre42 · 21 Juillet 2023

job75 à dit:

Bonjour Patrick,

En fait on peut différencier en ajoutant un test dans la formule :

VB:

Sub Copie()
Dim lig As Integer, p As String, nomfich As String, f As String
Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
Range("A2:D65536").ClearContents 'efface la plage de restitution
lig = 2 'restitution à partir de la ligne 2 (si titres en ligne 1)
p = ThisWorkbook.Path & "\"
nomfich = Dir(p & "*.xls") '1er fichier du dossier
While nomfich <> ""
  If nomfich <> ThisWorkbook.Name Then
    Cells(lig, 1) = nomfich 'nom du fichier en colonne A
    f = "'" & p & "[" & nomfich & "]Feuil1'!C6" 'Feuil1 => nom de la feuille à adapter...
    Cells(lig, 2).Formula = "=IF(" & f & "="""",""""," & f & ")"
    f = "'" & p & "[" & nomfich & "]Feuil1'!C81"
    Cells(lig, 3).Formula = "=IF(" & f & "="""",""""," & f & ")"
    f = "'" & p & "[" & nomfich & "]Feuil1'!C83"
    Cells(lig, 4).Formula = "=IF(" & f & "="""",""""," & f & ")"
    Cells(lig, 2).Resize(, 3) = Cells(lig, 2).Resize(, 3).Value 'facultatif, si l'on veut supprimer les formules
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
End Sub

A+

Merci beaucoup pour cette proposition qui m'emballe plus qu'un powerquery plus complexe à mettre en place. Malheureusement ça ne fonctionne pas

J'ai adapté ce code à mon fichier (en modifiant simplement le nom de feuille et les cellules visées), la macro ne me renvoie plus aucune valeur mais seulement des cellules vides.

Cousinhub · 21 Juillet 2023

Bonjour,

Pierre42 à dit:
Merci beaucoup pour cette proposition qui m'emballe plus qu'un powerquery plus complexe à mettre en place.

Je trouve ce jugement un peu hâtif...
As-tu essayé?
Je pense tout d'abord que tu devrais créer ton propre fil (afin d'indiquer la version Excel que tu utilises, en premier lieu, et peut-être aussi d'éviter que l'initiateur de ce fil ne reçoive de mails lui signifiant des nouvelles réponses à sa question de plus de 13 ans...- Edit : ou presque...)

job75 · 21 Juillet 2023

Bonjour Pierre42, le forum,

Pierre42 à dit:
J'ai adapté ce code à mon fichier (en modifiant simplement le nom de feuille et les cellules visées), la macro ne me renvoie plus aucune valeur mais seulement des cellules vides.

Joignez vos 2 fichiers, éventuellement allégés et sans données confidentielles.

Pour tester ils doivent être dans le même dossier.

A+

job75 · 21 Juillet 2023

job75 à dit:
Pour tester ils doivent être dans le même dossier.

Et donc bien sûr le fichier contenant la macro doit avoir été enregistré...

Pierre42 · 21 Juillet 2023

job75 à dit:
Bonjour Pierre42, le forum,

Joignez vos 2 fichiers, éventuellement allégés et sans données confidentielles.

Pour tester ils doivent être dans le même dossier.

A+

job75 à dit:
Et donc bien sûr le fichier contenant la macro doit avoir été enregistré...

Petite erreur d'inattention de ma part, j'ai oublié de modifier l'extension .xls en .xlsx ... Ca fonctionne désormais parfaitement !

Merci beaucoup pour votre aide.

Désolé à l'auteur du sujet pour le déterrage du sujet et les possibles envoi de mails intempestifs. Pour powerquery j'avoue ne pas être pour l'instant très à l'aise avec cet outil et la création de requête. Mon essai n'a pas été concluant.

job75 · 21 Juillet 2023

Pierre42 à dit:
Petite erreur d'inattention de ma part, j'ai oublié de modifier l'extension .xls en .xlsx ..

Quelle est votre version Excel ? Chez moi sur Excel 2019 Dir(p & "*.xls") traite aussi les fichiers xlsx et xlsm.

Pour terminer voici une macro plus générale pour traiter plusieurs adresses de cellules :

VB:

Sub Copie()
Dim lig%, p$, nomfich$, feuille$, a, i%, f$
lig = 2 'restitution à partir de la ligne 2 (si titres en ligne 1)
p = ThisWorkbook.Path & "\"
nomfich = Dir(p & "*.xls*") '1er fichier du dossier
feuille = "Feuil1" 'à adapter
a = Array("C6", "C81", "C83") 'liste des adresses
Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
Rows(lig & ":" & Rows.Count).ClearContents 'efface la plage de restitution
While nomfich <> ""
  If nomfich <> ThisWorkbook.Name Then
    Cells(lig, 1) = nomfich 'nom du fichier en colonne A
    For i = 0 To UBound(a)
        f = "'" & p & "[" & nomfich & "]" & feuille & "'!" & a(i)
        Cells(lig, i + 2).Formula = "=IF(" & f & "="""",""""," & f & ")"
    Next i
    Cells(lig, 2).Resize(, i) = Cells(lig, 2).Resize(, i).Value 'facultatif, si l'on veut supprimer les formules
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
End Sub

aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme reperto

floR54

XLDnaute Nouveau

job75

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pierre42

XLDnaute Nouveau

Cousinhub

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pierre42

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Discussions similaires

aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme reperto

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency