Boucle Extraire donnés d'un fichier dans onglet de même nom

JVOS

XLDnaute Junior
Bonjour à tous
J'ai plusieurs fichiers sources qui se nomment 1, 2, 3.
Chaque ficher à une seule Feuille. Tous les fichiers sont dans un seul dossier.
Je dois récupérer dans un fichier Cible les colonnes "A:D" de chaque fichier dans la feuille ayant le même nom que le fichier source.
En pratique :
J'ouvre mon Fichier ("1")
Je sélectionne mes colonnes ("A:D")
J'active mon fichier Cible
Je colle en B1 dans la Feuille ("1")
Je ferme le Fichier ("1")
Et je passe au suivant avec le Fichier ("2") et Feuille ("2") du fichier cible.

J'ai pas beaucoup d’expérience en VBA et j'ai pas pu aboutir
Aidez moi svp

Private Sub Workbook_Open()

Chemin = "C:\Users\HP\Documents\TEST"
Fichier = Dir(Chemin & "*.xlsx")
Do While Fichier <> ""
Workbooks.Open Filename:=Chemin & Fichier
Range("A:D").Select
Selection.Copy
ThisWorkbook.Activate
ActiveSheet.Paste Destination:=Worksheets(Fichier).Range("B1")
Windows(Fichier).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
Fichier = Dir ' Fichier suivant
Loop

End Sub
 

sousou

XLDnaute Barbatruc
Bonjour
pas besoin de sélectionner pour copier coller
manque un antislash pour accéder au fichier
essai ceci, mais pas testé.
Private Sub Workbook_Open()
Chemin = "C:\Users\HP\Documents\TEST\"
Fichier = Dir(Chemin & "*.xlsx")
Do While Fichier <> ""
set source= Workbooks.Open (Chemin & Fichier)
source.colums(1).copy=thisworkbook.sheets(Fichier).columns(2)
source.save savechange:=false
Fichier = Dir ()' Fichier suivant
Loop

End Sub
 

JVOS

XLDnaute Junior
Bonjour Sousou
Pour
source.colums(1).copy=thisworkbook.sheets(Fichier).columns(2)
Ça m'indique "L'indice n’appartient pas à la sélection"

J'ai joints les fichiers

Merci pour ton aide
 

Pièces jointes

  • 1.xlsx
    9.6 KB · Affichages: 6
  • 2.xlsx
    9.6 KB · Affichages: 3
  • CL3.xlsx
    9.6 KB · Affichages: 3
  • Classeur1.xlsm
    17.1 KB · Affichages: 3

Staple1600

XLDnaute Barbatruc
Re

Test OK sur mon PC avec ces modifs
VB:
Private Sub Workbook_Open()
Dim Chemin$, Fichier$, Nom$, source As Workbook
Chemin = "C:\Users\STAPLE\Documents\TESTS\"
Fichier = Dir(Chemin & "*.xlsx")
Do While Fichier <> ""
Nom = Split(Fichier, ".")(0)
Set source = Workbooks.Open(Chemin & Fichier)
source.Sheets(1).Columns(1).Copy ThisWorkbook.Sheets(Nom).Columns(2)
Application.CutCopyMode = False
source.Close False
Fichier = Dir() ' Fichier suivant
Loop
End Sub
NB: Pense à remettre le bon chemin dans le code.
 

JVOS

XLDnaute Junior
Merci beaucoup Staple1600
J'ai résolu mon problème en insérant un For i

Private Sub Workbook_Open()

Dim Chemin$, Fichier$, Nom$, source As Workbook
Dim i As Integer

Chemin = "C:\Users\HP\Documents\TEST\"
Fichier = Dir(Chemin & "*.xlsx")
Do While Fichier <> ""
Nom = Split(Fichier, ".")(0)
Set source = Workbooks.Open(Chemin & Fichier)
For i = 1 To 4
source.Sheets(1).Columns(i).Copy ThisWorkbook.Sheets(Nom).Columns(i + 1)
Next i
Application.CutCopyMode = False
source.Close False
Fichier = Dir() ' Fichier suivant
Loop
End Sub
 

Staple1600

XLDnaute Barbatruc
Re

Je t'aurais alors proposé cette syntaxe ;)
VB:
Private Sub Workbook_Open()
Dim Chemin$, Fichier$, Nom$, source As Workbook
Chemin = "C:\Users\STAPLE\Documents\TEST\"
Fichier = Dir(Chemin & "*.xlsx")
Do While Fichier <> ""
Nom = Split(Fichier, ".")(0)
Set source = Workbooks.Open(Chemin & Fichier)
source.Sheets(1).Range("A:D").Copy ThisWorkbook.Sheets(Nom).Range("A:D")
Application.CutCopyMode = False
source.Close False
Fichier = Dir() ' Fichier suivant
Loop
End Sub
EDITION: Ah revoilou, sousou (salutations du soir) ;)
 

JVOS

XLDnaute Junior
Bonjour SebSemdee
J'ai installé PowerQuery
Mais mes fichiers .xls ne peuvent être ouvert car « La table externe n'est pas dans le format attendu. »
Il y a des entête de colonne vide
Cd
 
Dernière édition:

Discussions similaires

Réponses
4
Affichages
491
Réponses
5
Affichages
377