Private Sub Workbook_Activate()
Dim chemin$, fichier$, F As Worksheet, col%
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Sheets("Feuil1") 'à adapter
col = 1
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
F.[B:B].Resize(, F.Columns.Count - 1).Delete 'RAZ
While fichier <> ""
With Workbooks.Open(chemin & fichier).Sheets(1)
col = col + 1
F.Cells(2, col) = Left(.Parent.Name, Len(.Parent.Name) - 5)
F.Cells(3, col) = .Cells(4, 2)
F.Cells(4, col) = .Cells(5, 2)
F.Cells(5, col) = .Cells(6, 2)
F.Cells(6, col) = .Cells(3, 7)
F.Cells(7, col) = .Cells(4, 7)
F.Cells(8, col) = .Cells(9, 7)
F.Cells(9, col) = .Cells(9, 8)
F.Cells(12, col) = .Cells(19, 10)
F.Cells(13, col) = .Cells(20, 10)
F.Cells(14, col) = .Cells(21, 10)
F.Cells(15, col) = .Cells(22, 10)
F.Cells(16, col) = .Cells(23, 10)
F.Cells(17, col) = .Cells(24, 10)
.Parent.Close
End With
fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
Bonjour JOB 75,Bonsoir Oliiive, chris,
Pourquoi pas du VBA ?
Téléchargez les fichiers joints dans le même dossier (le bureau).
Et voyez cette macro dans le ThisWorkbook du fichier Synthèse.xlm :
Elle se déclenche quand on ouvre ou active le fichier.VB:Private Sub Workbook_Activate() Dim chemin$, fichier$, F As Worksheet, col% chemin = ThisWorkbook.Path & "\" fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier Set F = Sheets("Feuil1") 'à adapter col = 1 Application.ScreenUpdating = False Application.EnableEvents = False 'désactive les évènements F.[B:B].Resize(, F.Columns.Count - 1).Delete 'RAZ While fichier <> "" With Workbooks.Open(chemin & fichier).Sheets(1) col = col + 1 F.Cells(2, col) = Left(.Parent.Name, Len(.Parent.Name) - 5) F.Cells(3, col) = .Cells(4, 2) F.Cells(4, col) = .Cells(5, 2) F.Cells(5, col) = .Cells(6, 2) F.Cells(6, col) = .Cells(3, 7) F.Cells(7, col) = .Cells(4, 7) F.Cells(8, col) = .Cells(9, 7) F.Cells(9, col) = .Cells(9, 8) F.Cells(12, col) = .Cells(19, 10) F.Cells(13, col) = .Cells(20, 10) F.Cells(14, col) = .Cells(21, 10) F.Cells(15, col) = .Cells(22, 10) F.Cells(16, col) = .Cells(23, 10) F.Cells(17, col) = .Cells(24, 10) .Parent.Close End With fichier = Dir 'fichier suivant Wend F.Columns.AutoFit 'ajustement largeurs Application.EnableEvents = True 'réactive les évènements End Sub
A+
Merci Chris !!Bonjour
Plutôt à faire par PowerQuery que par VBA
Modifier le chemin d'accès de la cellule jaune et les paramètres de PowerQuery
Fichier, Options et paramètres, Options de requête, partie GLOBAL : Confidentialité, Toujours ignorer les paramètres de niveau de confidentialité
Puis actualiser
Vous êtes sur MAC ? Si oui il faudra modifier le code.Après avoir copier vos fichiers dans un repertoire sur mon bureau et ouvert le fichier synthèse, j'ai une erreur "nom ou numéro du fichier incorrect" débogage en jaune sur fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier. Fallait il que je modifie cette ligne ?
Private Sub Workbook_Activate()
Dim chemin$, fichier$, F As Worksheet, col%
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
Set F = Sheets("Feuil1") 'à adapter
col = 1
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
F.[B:B].Resize(, F.Columns.Count - 1).Delete 'RAZ
While fichier <> ""
If Right(fichier, 5) = ".xlsx" Then
With Workbooks.Open(chemin & fichier).Sheets(1)
col = col + 1
F.Cells(2, col) = Left(fichier, Len(fichier) - 5)
F.Cells(3, col) = .Cells(4, 2)
F.Cells(4, col) = .Cells(5, 2)
F.Cells(5, col) = .Cells(6, 2)
F.Cells(6, col) = .Cells(3, 7)
F.Cells(7, col) = .Cells(4, 7)
F.Cells(8, col) = .Cells(9, 7)
F.Cells(9, col) = .Cells(9, 8)
F.Cells(12, col) = .Cells(19, 10)
F.Cells(13, col) = .Cells(20, 10)
F.Cells(14, col) = .Cells(21, 10)
F.Cells(15, col) = .Cells(22, 10)
F.Cells(16, col) = .Cells(23, 10)
F.Cells(17, col) = .Cells(24, 10)
.Parent.Close
End With
End If
fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
Private Sub Workbook_Activate()
Dim chemin$, fichier$, feuille$, source, lig, Cn As Object, Cd As Object, Rst As Object, col%, resu(), i%
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
feuille = "Feuil1" 'feuille source à copier
source = Array("B4", "B5", "B6", "G3", "G4", "G9", "H9", "J19", "J20", "J21", "J22", "J23", "J24") 'adresses des cellules
lig = Array(3, 4, 5, 6, 7, 8, 9, 12, 13, 14, 15, 16, 17) 'lignes de destination
Set Cn = CreateObject("ADODB.Connection")
Set Cd = CreateObject("ADODB.Command")
Set Rst = CreateObject("ADODB.Recordset")
While fichier <> ""
If Right(fichier, 5) = ".xlsx" Then
col = col + 1
Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
Cd.ActiveConnection = Cn
ReDim Preserve resu(1 To 17, 1 To col) 'tableau des résultats
resu(2, col) = Left(fichier, Len(fichier) - 5)
For i = 0 To UBound(source)
Cd.CommandText = "SELECT * FROM [" & feuille & "$" & source(i) & ":" & source(i) & "]"
Rst.Open Cd, , 1, 3
resu(lig(i), col) = Rst(0)
Rst.Close
Next i
Cn.Close
End If
fichier = Dir 'fichier suivant
Wend
'---restitution---
With Sheets("Feuil1")
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
With .[B1] '1ère cellule de destination
If col Then .Resize(UBound(resu), col) = resu
.EntireColumn.Offset(, col).Resize(, .Parent.Columns.Count - col - .Column + 1).Delete 'RAZ à droite
End With
.Columns.AutoFit 'ajustement largeurs
With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub
Merci ! Mais ça ne marche pas ... :-//Et une 2ème version avec ADO qui ne nécessite pas l'ouverture des fichiers sources .xlsx :
Code:Private Sub Workbook_Activate() Dim chemin$, fichier$, feuille$, source, lig, Cn As Object, Cd As Object, Rst As Object, col%, resu(), i% chemin = ThisWorkbook.Path & Application.PathSeparator fichier = Dir(chemin) '1er fichier du dossier feuille = "Feuil1" 'feuille source à copier source = Array("B4", "B5", "B6", "G3", "G4", "G9", "H9", "J19", "J20", "J21", "J22", "J23", "J24") 'adresses des cellules lig = Array(3, 4, 5, 6, 7, 8, 9, 12, 13, 14, 15, 16, 17) 'lignes de destination Set Cn = CreateObject("ADODB.Connection") Set Cd = CreateObject("ADODB.Command") Set Rst = CreateObject("ADODB.Recordset") While fichier <> "" If Right(fichier, 5) = ".xlsx" Then col = col + 1 Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;""" Cd.ActiveConnection = Cn ReDim Preserve resu(1 To 17, 1 To col) 'tableau des résultats resu(2, col) = Left(fichier, Len(fichier) - 5) For i = 0 To UBound(source) Cd.CommandText = "SELECT * FROM [" & feuille & "$" & source(i) & ":" & source(i) & "]" Rst.Open Cd, , 1, 3 resu(lig(i), col) = Rst(0) Rst.Close Next i Cn.Close End If fichier = Dir 'fichier suivant Wend '---restitution--- With Sheets("Feuil1") If .FilterMode Then .ShowAllData 'si la feuille est filtrée With .[B1] '1ère cellule de destination If col Then .Resize(UBound(resu), col) = resu .EntireColumn.Offset(, col).Resize(, .Parent.Columns.Count - col - .Column + 1).Delete 'RAZ à droite End With .Columns.AutoFit 'ajustement largeurs With .UsedRange: End With 'actualise la barre de défilement horizontale End With End Sub
Vous êtes sur MAC ?
Hello Staple1600Bonjour le fil, Oliiive, job75
[juste pour infos]
j'ai testé les fichiers du message#9 (sur Office 695 PC)
Cela fonctionne aussi chez moi
[/juste pour infos]