Extraction ligne 1 de plusieurs dossiers pour en faire qu'un
Bonjour à vous,
J'ai 52 classeurs dans un dossiers, je voudrais en extraire la ligne 1 de la colonne D à BC de chacun de ces classeurs, sur une seule feuille d'un nouveau classeur (chaque lignes de ces classeur sur une ligne de ce nouveau classeur
Tout les classeurs sont dans le même répertoire.
Merci d'avance.
Bonjour
Même type de demande que dans ce fil :
Il te suffit de modifier la plage d'extraction :
Sub Importe()
Dim dossier As Object, Fichier As Object, Chemin As String, Lg As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("A2:BA65536").ClearContents
Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls")
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In dossier.Files
NomFichier = Fichier.Name
If Not Fichier.Name = "IMPORT.xls" Then
Lg = Range("A65536").End(xlUp).Row + 1
Workbooks.Open Filename:=Chemin & "/" & NomFichier
On Error Resume Next
With Workbooks(NomFichier)
.Sheets("Feuil3").Range("D1:BC1").Copy
ThisWorkbook.Sheets("Feuil1").Range("A" & Lg).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Close
End With
End If
Next
Application.DisplayAlerts = True
End SubAmicalement
Nad
Merci nad, c'est vraie que c'est plus ou moins la même chose, j'avais d’ailleurs commencé à modifier la macro...
Mais même avec ces modifications sa ne fonctionne pas...
Les classeurs sont des xlsm, donc j'ai modifié:
Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls")en
Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls")De même ma feuil1 s’appelle Hoja1, je l'ai aussi changer, mais sa n'a rien donné.
Voilà deux exemples fictifs (les fichiers originaux sont beaucoup trop lourds) et le résultat voulus.
Re
Le code adapté :
Sub Importe()
Dim dossier As Object, Fichier As Object, Chemin As String, Lg As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("D1:BD65536").ClearContents
Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls")
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In dossier.Files
NomFichier = Fichier.Name
If Not Fichier.Name = "Résultat.xls" Then
Lg = Range("D65536").End(xlUp).Row + 1
Workbooks.Open Filename:=Chemin & "/" & NomFichier
On Error Resume Next
With Workbooks(NomFichier)
.Sheets("Hoja1").Range("D1:BC1").Copy
ThisWorkbook.Sheets("Hoja1").Range("D" & Lg).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Close
End With
End If
Next
Rows(1).Delete
Range("A1").Activate
Application.DisplayAlerts = True
End SubAmicalement
Nad
Bonjour Basosa, Nad,
Une autre approche, avec la méthode DIR.
Convient pour les fichiers xls, xlsx, xlsm
A+
Merci à vous deux,
Pour la première macro de rien ne se passe,
et pour la seconde j'ai fait un test, sa c'est bien passé, mais par contre quant je la lance sur le dossier j'ai une erreur sur la ligne:
With workbooks.open(fichier)Ton problème c'est que tu est sur un classeur xls (97 - 2003) et que tu veux ouvrir des classeurs xlsm (=>2007)
Tu dois ouvrir le classeur sur Excel 2007 ou plus.
A+
Effectivement sa marche, du moins c'est lancé, sa vas prendre pas mal de temps...
Je vous tiens au courant.
Pas mal de temps...
J'ai testé avec 205 classeurs et ça a pris moins de 30 secondes ?
Re
Pour la première macro de rien ne se passe
Pourtant mon test est OK
Remplace ton fichier Résultat par celui-ci et dis-moi
Nad
Ok pour la macro de lermite c'est bon. Oui beaucoup de temps, car les classeurs a importé sont 52 chacun avec 52 onglets chacun avec deux colonnes à 20 000 données, donc voilà...
Pour la macro de Nad elle est lancé, donc je préviens dès que c'est finis.
ok c'est bon, les deux macro fonctionnes, merci a vous deux.