Récupération de certaines cellules dans plusieurs fichiers XLS

illidan05

XLDnaute Nouveau
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 :

Code:
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++
 

Robert

XLDnaute Barbatruc
Repose en paix
Re : Récupération de certaines cellules dans plusieurs fichiers XLS

Bonjour Illidan, bonjour le forum,

peut-être comme ça :
Code:
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("E18").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)
            .Range("H34").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)
            .Range("I22").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
Application.ScreenUpdating = True
End Sub
 

illidan05

XLDnaute Nouveau
Re : Récupération de certaines cellules dans plusieurs fichiers XLS

Bonjour Robert,

Merci beaucoup pour ce code qui fonctionne parfaitement. Si je peux te demander encore un service, je souhaiterais que les 3 valeurs récupérées soient réparties sur 3 colonnes et une seule ligne alors qu'actuellement les valeurs sont sur une colonne et 3 lignes.

Actuellement, les données récupérées sont sous la forme :
E18
H34
I22
E18
H34
I22
...

Format souhaité :
E18 | H34 | I22
E18 | H34 | I22
E18 | H34 | I22
E18 | H34 | I22
E18 | H34 | I22

Merci d'avance pour ton aide
Bonne journée
 

Robert

XLDnaute Barbatruc
Repose en paix
Re : Récupération de certaines cellules dans plusieurs fichiers XLS

Bonjour Illidan, bonjour le forum,

Je m'en doutais un peu... Essaie comme ça :

Code:
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("E18").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1, 0)
            .Range("H34").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1, 1)
            .Range("I22").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1, 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
 

Discussions similaires

Réponses
4
Affichages
491
Réponses
19
Affichages
2 K

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib