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

floR54

XLDnaute Nouveau
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
 

laurent999

XLDnaute Occasionnel
Re : aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme re

La première partie ouvre chaque classeur du même répertoire.
Ce qui est en vert est l'action réalisée pour chaque classeur vers le classeur d'ou est lancé la macro.
dans l'exemple ici on copie les lignes des autres classeurs.
et on vient les coller à la suite dans le classeur d'ou est lancé la macro.
Tous les classeurs sont fermés à la fin.
sub lenomquetuveux()
Dim Repertoire As String, FichS As String, FichD As Workbook
Repertoire = ThisWorkbook.Path
Set FichD = ActiveWorkbook
FichS = Dir(Repertoire & "*.xlsm ou xls ou encore xlsx")
Do While FichS <> ""
Derlign = ActiveSheet.Range("A60000").End(xlUp).Row + 1
Workbooks.Open Repertoire & FichS
Sheets(".....").Select
Sheets("....").Range("A1:Y10000").Copy FichD.Sheets("....").Range("A" & Derlign)
Application.CutCopyMode = False

Workbooks(FichS).Close
FichS = Dir
Loop
end sub
 

floR54

XLDnaute Nouveau
Re : aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme re

La première partie ouvre chaque classeur du même répertoire.
Ce qui est en vert est l'action réalisée pour chaque classeur vers le classeur d'ou est lancé la macro.
dans l'exemple ici on copie les lignes des autres classeurs.
et on vient les coller à la suite dans le classeur d'ou est lancé la macro.
Tous les classeurs sont fermés à la fin.
sub lenomquetuveux()
Dim Repertoire As String, FichS As String, FichD As Workbook
Repertoire = ThisWorkbook.Path
Set FichD = ActiveWorkbook
FichS = Dir(Repertoire & "*.xlsm ou xls ou encore xlsx")
Do While FichS <> ""
Derlign = ActiveSheet.Range("A60000").End(xlUp).Row + 1
Workbooks.Open Repertoire & FichS
Sheets(".....").Select
Sheets("....").Range("A1:Y10000").Copy FichD.Sheets("....").Range("A" & Derlign)
Application.CutCopyMode = False

Workbooks(FichS).Close
FichS = Dir
Loop
end sub


Merci Laurent999 de te pencher sur mon problème. Comme je ne comprends pas tout, peux tu me dire où je dois mettre les 3 cellules (c6, c81 et c85) de chque classeur que je veux recopier dans mon autre classeur ??

et à la place des "..." dans Sheets(".....").Select, je dois mettre le nom de la feuille c 'est ca ??

Encore merci de ton aide

Flor54
 

job75

XLDnaute Barbatruc
Re : aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme re

Bonjour le fil,

Solution avec cette macro dans un Module du fichier "Recap" :

Code:
Sub Copie()
Dim lig As Integer, p As String, nomfich 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
    Cells(lig, 2).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C6"  'Feuil1 => nom de la feuille à adapter...
    Cells(lig, 3).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C81"
    Cells(lig, 4).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C83"
    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+
 

floR54

XLDnaute Nouveau
Re : aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme re

Bonjour le fil,

Solution avec cette macro dans un Module du fichier "Recap" :

Code:
Sub Copie()
Dim lig As Integer, p As String, nomfich 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
    Cells(lig, 2).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C6"  'Feuil1 => nom de la feuille à adapter...
    Cells(lig, 3).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C81"
    Cells(lig, 4).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C83"
    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+

C'est super, ca marche trop trop bien et en plus il n'y a même pas besoin de spécifier dans le code le chemin !!

Super boulot!

encore merci !!

Flor54
 

job75

XLDnaute Barbatruc
Re : aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme re

Bonjour bbruno,

Ce n'est pas le sujet du fil : la macro va chercher les données de plusieurs fichiers.

Votre problème est a priori simple, refaites une recherche sur le forum.

A+
 

Pierre42

XLDnaute Nouveau
Re : aide vba : copier celulles de plusieurs fichiers fermés dans un autre du meme re

Bonjour le fil,

Solution avec cette macro dans un Module du fichier "Recap" :

Code:
Sub Copie()
Dim lig As Integer, p As String, nomfich 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
    Cells(lig, 2).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C6"  'Feuil1 => nom de la feuille à adapter...
    Cells(lig, 3).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C81"
    Cells(lig, 4).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C83"
    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+
Bonjour,

Petit déterrage de post.

Tout d'abord merci, j'ai adapté cette macro pour mon projet. Elle est simple et efficace. Seul bémol, les cellules récupérées sont parfois vides. Dans le fichier recap. au lieu de m'afficher une cellule vide il m'inscrit un 0. J'aurais souhaité conserver mes cellules vides. Malgré divers tentatives, je n'ai pas réussi à différencier les cellules vides des 0. Pouvez vous m'aider ?

Merci
 

job75

XLDnaute Barbatruc
Bonjour Pierre42:

Il suffit d'effacer les valeurs zéro, la macro complétée :
VB:
Sub Copie()
Dim lig As Integer, p As String, nomfich As String
Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
Range("A2:D" & Rows.Count).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
    Cells(lig, 2).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C6"  'Feuil1 => nom de la feuille à adapter...
    Cells(lig, 3).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C81"
    Cells(lig, 4).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C83"
    Cells(lig, 2).Resize(, 3) = Cells(lig, 2).Resize(, 3).Value 'supprime les formules
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
Cells(2, 2).Resize(lig - 1, 3).Replace 0, "", xlWhole 'efface les valeurs zéro
End Sub
A+
 

Pierre42

XLDnaute Nouveau
Bonjour Pierre42:

Il suffit d'effacer les valeurs zéro, la macro complétée :
VB:
Sub Copie()
Dim lig As Integer, p As String, nomfich As String
Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
Range("A2:D" & Rows.Count).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
    Cells(lig, 2).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C6"  'Feuil1 => nom de la feuille à adapter...
    Cells(lig, 3).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C81"
    Cells(lig, 4).Formula = "='" & p & "[" & nomfich & "]Feuil1'!C83"
    Cells(lig, 2).Resize(, 3) = Cells(lig, 2).Resize(, 3).Value 'supprime les formules
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
Cells(2, 2).Resize(lig - 1, 3).Replace 0, "", xlWhole 'efface les valeurs zéro
End Sub
A+

Merci pour la réponse, malheureusement j'ai aussi des valeurs 0 que je souhaite conserver. Il faut donc que je différencie les cellules contenant un 0 des cellules vides (non renseignées)
 

Discussions similaires

Statistiques des forums

Discussions
311 730
Messages
2 081 991
Membres
101 856
dernier inscrit
Marina40