Récupération de certaines cellules dans plusieurs fichiers
Bonjour à tous,
J'ai trouvé dans un sujet du forum un exemple d'une macro qui répond presque entièrement à mon besoin. A la différence près que j'ai besoin de récupérer seulement les valeurs de certaines cellules et non l'intégralité des cellules utilisées dans les classeurs XLS.
Voici la macro fonctionnelle que j'ai pu tester :
Option Explicit
Sub importDonnees()
Dim principal As ThisWorkbook
Dim repertoire As String, fichier As String
Application.ScreenUpdating = False
Set principal = ThisWorkbook
repertoire = ThisWorkbook.Path
ChDir repertoire
fichier = Dir("*.xls")
Do While fichier <> ""
If fichier <> principal.Name Then
Workbooks.Open fichier
On Error GoTo suivant
With Sheets("synth")
On Error GoTo 0
On Error Resume Next
.[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.[A:A].Insert Shift:=xlToRight
.Range("A1:A" & .[b65536].End(xlUp).Row) = Left(fichier, Len(fichier) - 4)
.UsedRange.EntireRow.Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)
End With
ActiveWorkbook.Close False
End If
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""synth"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
fichier = Dir
Loop
End Sub
Cette macro récupère les données de tous les fichiers XLS présents dans le même répertoire que le fichier qui exécute cette macro.
J'aurais besoin de modifier ce code pour récupérer uniquement les valeurs des cellules E18, H34 et I22. Savez-vous comment modifier le code pour récupérer les valeurs de ces 3 cellules ?
Merci d'avance pour votre aide
A++
Bonjour,
Tu peux tester :
.Range("E18,H34,I22").Copy
à la place de
.UsedRange.EntireRow.Copy
A+
Bonjour,
Voici le code fonctionnel que j'ai reçu si ça peut aider :
Option Explicit
Sub importDonnees()
Dim principal As Workbook
Dim repertoire As String, fichier As String
Application.ScreenUpdating = False
Set principal = ThisWorkbook
repertoire = ThisWorkbook.Path
ChDir repertoire
fichier = Dir("*.xls")
Do While fichier <> ""
If fichier <> principal.Name Then
Workbooks.Open fichier
On Error GoTo suivant
With Sheets("synth")
On Error GoTo 0
On Error Resume Next
.Range("C6").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1, 0)
.Range("D7").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(0, 1)
.Range("E8").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(0, 2)
End With
ActiveWorkbook.Close False
End If
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""synth"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
fichier = Dir
Loop
Application.ScreenUpdating = True
End Sub
Bonne soirée