Récuperer 4 cellules de X fichiers

Bonjour,

Je voulais savoir si vous connaissez un moyen de recuperer dans un fichier 4 cellules situés toujours au même endroit des différents fichiers

tous sur le feuil1, Cellule A1, D7, B3, K1.

J'ai trouvé un moyen pour récuperer tous les contenus d'un fichier, de A à K par exemple, mais je n'arrive pas à récupérer seulement 4 cellules par fichier..

Pouvez vous m'aider?

cdt

Anthooooony

Salut,

anthooooony a écrit :

J'ai trouvé un moyen pour récuperer tous les contenus d'un fichier, de A à K par exemple

Alors fourni nous déjà la partie de ton travail qui fonctionne et l'on pourra facilement t'aider à l'améliorer Ca évite de partir sur un tout nouveau code bien différent du tien.

Cordialement.

Bonjour,

Merci de ton retour,

Oui j'ai oublié de mettre le code, désolé.

Je me sers de ce code pour récuperer toute les colonnes de mes fichiers recus au quotidien.

Mais on me demande, pour un nouveau travail, de recuperer seulement 4 cellules précises qui se trouve dans la feuil1 d'une 100 de fichier. Ces cellules se trouvent à des endroits différents dans cette feuil1.

Private Sub Workbook_Open()

sousRépertoire = "TEST"

[A2].CurrentRegion.Offset(1, 0).Clear

Set maitre = ActiveWorkbook

Repertoire = ThisWorkbook.Path

nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier

Do While nf <> ""

Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf

n = [A1].CurrentRegion.Rows.Count - 1

[A1].CurrentRegion.Offset(1, 0).Copy _

maitre.Sheets(1).[A65000].End(xlUp).Offset(1, 0)

ActiveWorkbook.Close False

'-- nom onglet

' [A1].End(xlDown).End(xlToRight).Offset(-n + 1, 1).Resize(n, 1) = Left(nf, Len(nf) - 4)

nf = Dir ' fichier suivant

ActiveWorkbook.RefreshAll

Loop

Application.DisplayAlerts = False

End Sub

Bonjour,

Voici ton code en retour avec modifications. Ce n'est bien entendu qu'un exemple de départ, à toi d'adapter.

Private Sub Workbook_Open()

 sousRépertoire = "TEST"
 [A2].CurrentRegion.Offset(1, 0).Clear
 Set maitre = ActiveWorkbook
 Repertoire = ThisWorkbook.Path
 nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
 Do While nf <> ""
 Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
'' n = [A1].CurrentRegion.Rows.Count - 1
'' [A1].CurrentRegion.Offset(1, 0).Copy _
'' maitre.Sheets(1).[A65000].End(xlUp).Offset(1, 0)
With ThisWorkbook.Sheets("Feuil1")
    .Range("A1") = Range("A1")
    .Range("A2") = Range("D7")
    .Range("A3") = Range("B3")
    .Range("A4") = Range("K1")
End With

 ActiveWorkbook.Close False
 '-- nom onglet
 ' [A1].End(xlDown).End(xlToRight).Offset(-n + 1, 1).Resize(n, 1) = Left(nf, Len(nf) - 4)
 nf = Dir ' fichier suivant
 ActiveWorkbook.RefreshAll

 Loop
 Application.DisplayAlerts = False

End Sub

Si tu as encore des problèmes, il faudrait fournir tout ton fichier.

Cordialement.

Rebonjour, encore merci de ton retour ci rapide.

Est il possible que dans la configuration de ton code, les données se mettent les unes en dessous des autres?

Je l'ai lancé, et il y a, qu'aprioris que le dernier classeur qui se met à dans le fichier recap.

Je n'arrive pas à voir quelle est la fonction qui lui dit de se mettre en dessous..

j'ai changé en mettant que les données se mettent en A1;B1;C1;D1.

Je continue à chercher.

cdt

anthooooony

Private Sub Workbook_Open()

 sousRépertoire = "TEST"
 [A2].CurrentRegion.Offset(1, 0).Clear
 Set maitre = ActiveWorkbook
 Repertoire = ThisWorkbook.Path
 nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
Do While nf <> ""
 Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
'' n = [A1].CurrentRegion.Rows.Count - 1
'' [A1].CurrentRegion.Offset(1, 0).Copy _
'' maitre.Sheets(1).[A65000].End(xlUp).Offset(1, 0)
With ThisWorkbook.Sheets("Feuil1")
    .Range("A1") = Range("A1")
    .Range("B1") = Range("D7")
    .Range("C1") = Range("B3")
    .Range("D1") = Range("K1")
End With

 ActiveWorkbook.Close False
 '-- nom onglet
' [A1].End(xlDown).End(xlToRight).Offset(-n + 1, 1).Resize(n, 1) = Left(nf, Len(nf) - 4)
nf = Dir ' fichier suivant
ActiveWorkbook.RefreshAll

 Loop
 Application.DisplayAlerts = False

End Sub

Re-bonjour,

Je t'avais bien dit que ce n'était qu'un exemple à adapter

Voici quelque chose de plus personnel :

Sub aaaaa()

Application.ScreenUpdating = False

 sousRépertoire = "TEST"
 [A2].CurrentRegion.Offset(1, 0).Clear
 Set maitre = ActiveWorkbook
 Repertoire = ThisWorkbook.Path
 nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
Do While nf <> ""
 Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
With ThisWorkbook.Sheets("Feuil1")
    derlig = .Range("A65000").End(xlUp).Row + 1
    .Range("A" & derlig) = Range("A1")
    .Range("B" & derlig) = Range("D7")
    .Range("C" & derlig) = Range("B3")
    .Range("D" & derlig) = Range("K1")
End With

 ActiveWorkbook.Close False

nf = Dir ' fichier suivant
ActiveWorkbook.RefreshAll

 Loop
 Application.DisplayAlerts = False

End Sub

Amicalement.

Bonsoir !!!

Merci beaucoup, tu m'as fait gagner beaucoup de temps, j'ai deja passé deux semaines à chercher comment faire pour récuperer ces satannés cellules !!!

Je n'ai pas tout les fondamentaux de VBA..

Merci encore d'avoir passé du temps sur mon problème.

bonnes fetes !!

Anthooooony