XL 2010 Récupérer les données de plusieurs fichiers pour un nom de feuille donné

[JVOS]

Bonjour
Je fais encore appel à vous car après beaucoup de recherches et d'essais, j'arriva pas à faire ce que je veux à ma macro.
J'ai des données sur plusieurs fichiers, même nom de feuille (nom de semaines type S25), dans un même dossier.
La macro doit :
Dans un fichier de synthèse (créer la feuille de semaine S23 (cette partie c'est ok))
- récupérer les lignes A2 à D20 de tous les fichiers les unes après les autres
- supprimer les lignes dont la colonne A est vide
Je vous donne ma macro en entier, en sachant que la création de la nouvelle feuille est ok.


Sub Nvlle_Feuille()
Dim BE As Variant
Dim I As Integer
Dim sRep As String
Dim sFichier As String

ici:
BE = Application.InputBox("Entrez le nom du nouvel onglet, type S+n°semaine ex. S25", "NOM", Type:=2)
If BE = False Or BE = "" Then Exit Sub
For I = 1 To Sheets.Count
If LCase(BE) = LCase(Sheets(I).Name) Then
MsgBox "Un onglet portant ce nom existe déjà, veuillez recommencer !"
GoTo ici
End If
Next I
ActiveSheet.Unprotect ("joker")
Sheets(1).Copy Before:=Sheets(1)
ActiveSheet.Name = BE
With Range("F3:AL50").SpecialCells(xlCellTypeVisible)
.ClearContents: .Interior.Color = xlColorIndexNone
End With
Range("AY3:BC50").ClearContents
Range("F2") = Range("F2") + 7

Application.ScreenUpdating = False
sRep = "C:\Users\HP\OneDrive\temporaire\TEST" 'Boîte de dialogue pour choisir répertoire ChoisirRepertoire & "\"

sFichier = Dir(sRep)
Do While sFichier <> ""
Workbooks.Open sRep & sFichier 'ouvrir le fichier

' Ici on veut récupèrer les valeurs des cellules A2 à D20 des feuilles portant le même nom que la feuille crée et les ranger à partir de A2 (ça ne copie pas les données)
ThisWorkbook.Sheets(BE).Range("A220").Copy.Value = ActiveWorkbook.Sheets(BE).Range("A2")
ActiveWorkbook.Close savechanges:=True

sFichier = Dir 'trouve le prochain fichier
Loop
Application.ScreenUpdating = True

'Ici on veut supprimer toutes les lignes vides, (mais ça fonctionne pas)
Range("A1").SpecialCells(xlCellTypeBlanks).EtireRow.Delete

ActiveSheet.Protect ("joker")
End Sub

Je vous remercie tous du temps que vous m'accorderez.

 

[zebanx]

Bonjour JVOS, le forum

Un essai.

Je n'arrivais pas à supprimer les lignes vides à partir de la copie de la feuille de départ (était-ce parce c'était un tableau?...) donc suis partie d'une feuille "modele" simple. Et là ça fonctionne bien (Sans mise en forme).

xl-ment
zebanx

 

[Hasco]

Bonjour,

Si vous êtes certain que la feuille existe dans le classeur externe, pour l'importation des données cette ligne devrait le faire:

ThisWorkbook.Sheets(BE).Range("A2:D20").Value = ActiveWorkbook.Sheets(BE).Range("A2:D20").Value

Et pour la suppression il y a une erreur de syntaxe:
Range("A1").SpecialCells(xlCellTypeBlanks).EtireRow.Delete au lieu de
Range("A1").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


Bon après-midi

Edit: bonjour @zebanx

 

[JVOS]

Bonjour JVOS, le forum

Un essai.

Je n'arrivais pas à supprimer les lignes vides à partir de la copie de la feuille de départ (était-ce parce c'était un tableau?...) donc suis partie d'une feuille "modele" simple. Et là ça fonctionne bien (Sans mise en forme).

xl-ment
zebanx

Merci pour ton aide
Malheureusement les fichiers à traiter sont des tableaux structurés...
Du coup effectivement Ça fonctionne pas

 

[JVOS]

Bonjour,

Si vous êtes certain que la feuille existe dans le classeur externe, pour l'importation des données cette ligne devrait le faire:

ThisWorkbook.Sheets(BE).Range("A2:D20").Value = ActiveWorkbook.Sheets(BE).Range("A2:D20").Value

Et pour la suppression il y a une erreur de syntaxe:
Range("A1").SpecialCells(xlCellTypeBlanks).EtireRow.Delete au lieu de
Range("A1").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


Bon après-midi

Edit: bonjour @zebanx

Bonjour Roblochon
Je comprend pas : ça me récupère pas mes données mais me donne en F2 le nombre de ligne que j'aurais du récupérer.

 

[Hasco]

Bonjour,

Chez moi cela fonctionne correctement avec le premier fichier puisque la deuxième n'a pas les bons noms de feuilles....

ThisWorkbook.Sheets(BE).Range("A2:D20").Copy.Value = ActiveWorkbook.Sheets(BE).Range("A2:D20").Value

Au sujet de : Range("A1").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ne retournera au mieux que la ligne de A1 et si A1 n'est pas vide, une erreur.
SpecialCells lève toujours une erreur quand il n'y pas de cellule correspondante.


Bonne soirée

 

[JVOS]

Bonjour,

Chez moi cela fonctionne correctement avec le premier fichier puisque la deuxième n'a pas les bons noms de feuilles....

ThisWorkbook.Sheets(BE).Range("A2:D20").Copy.Value = ActiveWorkbook.Sheets(BE).Range("A2:D20").Value

Au sujet de : Range("A1").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ne retournera au mieux que la ligne de A1 et si A1 n'est pas vide, une erreur.
SpecialCells lève toujours une erreur quand il n'y pas de cellule correspondante.


Bonne soirée

Effectivement CL2 n'a pas de feuille correspondante, c'est pour ça que je devrait récupérer 7 lignes en tout.
je ne comprend pas pourquoi ça copie pas. Il faut peut être cocher une case dans Référence

Au sujet de : Range("A1").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Je l'ai supprimé

 

[Hasco]

Re,

Dernière tentative. Cette macro fonctionne sur les classeurs donnés.
Elle contient deux nouvelles Variables : wsSource (Feuille source des données) et plageSource (cellules à récupérer)
Elle tente d'ouvrir le classeur n et teste si la feuille est présente
Si la feuille est présente, elle calcule le nombre de lignes de données à importer et fait l'import des valeurs.
Attention: Vous avez à faire à des Tableaux structurés (ListObjects) qui normalement se traitent différemment en vba pour l'ajout de lignes.
Pour la copie des données c'est pas bien grave mais pour le collage c'est autre chose.

Je n'ai pas le temps de voir tout ça ce soir on verra plus tard

Sub Nvlle_Feuille()
    Dim BE As Variant
    Dim I As Integer
    Dim sRep As String
    Dim sFichier As String
    Dim wsSource As Worksheet
    Dim plageSource As Range
    Dim count As Long
    ActiveSheet.Unprotect ("joker")
    Application.ScreenUpdating = False
    sRep = ThisWorkbook.Path & "\JVOS"      'Boîte de dialogue pour choisir répertoire ChoisirRepertoire & "\"
    BE = "S23"
    sFichier = Dir(sRep & "\*.xlsx")
    Do While sFichier <> ""
        Workbooks.Open sRep & "\" & sFichier  'ouvrir le fichier
        ' vérifier que la feuille existe dans le fichier source
        On Error Resume Next
        Set wsSource = ActiveWorkbook.Sheets(BE)
        On Error GoTo 0
        If Not wsSource Is Nothing Then
            'Compter le nombre de lignes ayant des données dans la colonne A de la source
            count = Application.CountA(wsSource.Range("A2:A20"))
            If count > 0 Then
                Set plageSource = wsSource.Range("A2").Resize(count, 4)
                With ThisWorkbook.Sheets(BE).Range("A2").ListObject
                    For I = 1 To count
                        .ListRows.Add().Range.Value = plageSource.Rows(I).Cells.Value
                    Next
                End With
            End If
            Set wsSource = Nothing
        End If
        ActiveWorkbook.Close savechanges:=False
        sFichier = Dir   'trouve le prochain fichier
    Loop
    Application.ScreenUpdating = True

    ActiveSheet.Protect ("joker")
End Sub

Bonne soirée

 

[JVOS]

Re,

Dernière tentative. Cette macro fonctionne sur les classeurs donnés.
Elle contient deux nouvelles Variables : wsSource (Feuille source des données) et plageSource (cellules à récupérer)
Elle tente d'ouvrir le classeur n et teste si la feuille est présente
Si la feuille est présente, elle calcule le nombre de lignes de données à importer et fait l'import des valeurs.
Attention: Vous avez à faire à des Tableaux structurés (ListObjects) qui normalement se traitent différemment en vba pour l'ajout de lignes.
Pour la copie des données c'est pas bien grave mais pour le collage c'est autre chose.

Je n'ai pas le temps de voir tout ça ce soir on verra plus tard

Sub Nvlle_Feuille()
    Dim BE As Variant
    Dim I As Integer
    Dim sRep As String
    Dim sFichier As String
    Dim wsSource As Worksheet
    Dim plageSource As Range
    Dim count As Long
    ActiveSheet.Unprotect ("joker")
    Application.ScreenUpdating = False
    sRep = ThisWorkbook.Path & "\JVOS"      'Boîte de dialogue pour choisir répertoire ChoisirRepertoire & "\"
    BE = "S23"
    sFichier = Dir(sRep & "\*.xlsx")
    Do While sFichier <> ""
        Workbooks.Open sRep & "\" & sFichier  'ouvrir le fichier
        ' vérifier que la feuille existe dans le fichier source
        On Error Resume Next
        Set wsSource = ActiveWorkbook.Sheets(BE)
        On Error GoTo 0
        If Not wsSource Is Nothing Then
            'Compter le nombre de lignes ayant des données dans la colonne A de la source
            count = Application.CountA(wsSource.Range("A2:A20"))
            If count > 0 Then
                Set plageSource = wsSource.Range("A2").Resize(count, 4)
                With ThisWorkbook.Sheets(BE).Range("A2").ListObject
                    For I = 1 To count
                        .ListRows.Add().Range.Value = plageSource.Rows(I).Cells.Value
                    Next
                End With
            End If
            Set wsSource = Nothing
        End If
        ActiveWorkbook.Close savechanges:=False
        sFichier = Dir   'trouve le prochain fichier
    Loop
    Application.ScreenUpdating = True

    ActiveSheet.Protect ("joker")
End Sub

Bonne soirée

Bonjour
Merci pour le temps que tu m'octrois.
J'ai joins des fichiers qui sont exactement le reflet des fichiers que j'ai (étant novice j'avais pas réalisé que les premiers fichiers étaient vraiment différents)

Ca coince à cette étape :
sFichier = Dir(sRep & "\*.xlsm")

Les feuilles ne s'appellerons pas toujours "S23" (elles évoluent en fonction des semaines)

Merci encore pour ton aide

 

[Hasco]

Bonjour,

"ça coince" ne nous dit rien sur ce qui coince! Quel message, quelle erreur! C'est aussi à vous d'adapter ce qu'on vous donne en étudiant chaque ligne de code et en vous aidant de la touche F1. Sélectionner un mot clef vba (comme Dir par exemple) et faites appel à F1.

Pour "S23", j'avais bien compris que les semaines changeaient. Pour les tests nous n'avons pas besoin de tous les faire, c'est pourquoi, de votre macro je n'ai gardé que ce qui me permettait de tester ce qui est en relation à votre question.

A ce propos, si vous voulez progresser dans l'apprentissage de VBA, je vous suggère, lorsque que vous avez un projet, comme celui-ci, de le décomposer en plusieurs étapes. Par exemple faire en premier la liste des fichiers du répertoire, voir si tout roule et éventuellement où "ça coince".
Une fois que cette étapes tourne sans erreur, passer à la suivante, ouvrir un fichier excel après avoir vérifier qu'il n'est pas déjà ouvert.
Ensuite chercher un feuille dans un classeur, si elle existe.
Comment récupérer une plage de cellule ou en retenir les valeurs.
Comment les transmettre dans un tableau structuré.
etc
Chaque étape étant acquise et fonctionnelle, passez à la suivante. Si vous voulez tout faire et obtenir en même temps, vous perdrez du temps et ne comprendrez pas ce que vous faites.

Pour ne pas vous laisser seul, voici un petit module dont vous pourrez éventuellement vous servir:

Sub test()
    Dim fichiers As Variant
    Dim i As Long
    Debug.Print "--- Liste des noms préfixés"
    ' Liste des noms préfixés du nom du répertoire
    fichiers = ListeFichiers(ThisWorkbook.Path, "*.xls?")
    If Not IsEmpty(fichiers) Then
        For i = 1 To UBound(fichiers)
            Debug.Print fichiers(i)
        Next
    End If
    Debug.Print "-"
    Debug.Print "--- Liste sans préfixe"
    ' Liste des noms non préfixés
    fichiers = ListeFichiers(ThisWorkbook.Path, "*.xls?", False)
    If Not IsEmpty(fichiers) Then
        For i = 1 To UBound(fichiers)
            Debug.Print fichiers(i)
        Next
    End If
End Sub

'
' Procédure ajoutant si besoin
' le séparateur final à un nom de répertoire
' le paramètre 'Répertoire' étant passé par référence
' sa valeur est modifiée
'
Sub AjouteSéparateur(ByRef Répertoire As String)
    If Répertoire = "" Then
        Répertoire = CurDir & Application.PathSeparator
    Else
        If Right(Répertoire, 1) <> Application.PathSeparator Then
            Répertoire = Répertoire & Application.PathSeparator
        End If
    End If
End Sub
'
' Function renvoyant un tableau des noms de fichier d'un répertoire
' Paramètre AvecRépertoire: préfixe (par défaut) les noms de fichier par le nom du répertoire.
' Paramètre 'Filtre' permet de ne renvoyer que les fichiers y répondant
' par exemple pour les fichiers excel > 2003 avec ou sans macro:  Filtre = "xls?"
'
Function ListeFichiers(ByVal Répertoire As String, _
                Optional ByVal Filtre As String = ".", _
                Optional ByVal AvecRépertoire As Boolean = True) As Variant
           
    Dim item As String
    Dim i As Long
    Dim res() As String
    AjouteSéparateur Répertoire
    item = Dir(Répertoire & Filtre)
    Do While item <> ""
        i = i + 1
        ReDim Preserve res(1 To i)
        res(i) = Array(item, Répertoire & item)(-AvecRépertoire)
        item = Dir
    Loop
    ListeFichiers = Array(Empty, res)(-(i > 0))
End Function
'
' Fonction renvoyant un classeur dont le nom est passé en paramètre
' S'il n'est pas ouvert, la fonction tentera de l'ouvrir à partir
' du répertoire donné
'
Function OuvrirClasseur(ByVal NomClasseur As String, ByVal Répertoire As String) As Workbook
    AjouteSéparateur Répertoire
    On Error Resume Next
    Set OuvrirClasseur = Workbooks(NomClasseur)
    If OuvrirClasseur Is Nothing Then Set OuvrirClasseur = Workbooks.Open(Répertoire & NomClasseur)
    On Error GoTo 0
FIN:
End Function

Bonne programmation

 

[JVOS]

Bonjour,

"ça coince" ne nous dit rien sur ce qui coince! Quel message, quelle erreur! C'est aussi à vous d'adapter ce qu'on vous donne en étudiant chaque ligne de code et en vous aidant de la touche F1. Sélectionner un mot clef vba (comme Dir par exemple) et faites appel à F1.

Pour "S23", j'avais bien compris que les semaines changeaient. Pour les tests nous n'avons pas besoin de tous les faire, c'est pourquoi, de votre macro je n'ai gardé que ce qui me permettait de tester ce qui est en relation à votre question.

A ce propos, si vous voulez progresser dans l'apprentissage de VBA, je vous suggère, lorsque que vous avez un projet, comme celui-ci, de le décomposer en plusieurs étapes. Par exemple faire en premier la liste des fichiers du répertoire, voir si tout roule et éventuellement où "ça coince".
Une fois que cette étapes tourne sans erreur, passer à la suivante, ouvrir un fichier excel après avoir vérifier qu'il n'est pas déjà ouvert.
Ensuite chercher un feuille dans un classeur, si elle existe.
Comment récupérer une plage de cellule ou en retenir les valeurs.
Comment les transmettre dans un tableau structuré.
etc
Chaque étape étant acquise et fonctionnelle, passez à la suivante. Si vous voulez tout faire et obtenir en même temps, vous perdrez du temps et ne comprendrez pas ce que vous faites.

Pour ne pas vous laisser seul, voici un petit module dont vous pourrez éventuellement vous servir:

Sub test()
    Dim fichiers As Variant
    Dim i As Long
    Debug.Print "--- Liste des noms préfixés"
    ' Liste des noms préfixés du nom du répertoire
    fichiers = ListeFichiers(ThisWorkbook.Path, "*.xls?")
    If Not IsEmpty(fichiers) Then
        For i = 1 To UBound(fichiers)
            Debug.Print fichiers(i)
        Next
    End If
    Debug.Print "-"
    Debug.Print "--- Liste sans préfixe"
    ' Liste des noms non préfixés
    fichiers = ListeFichiers(ThisWorkbook.Path, "*.xls?", False)
    If Not IsEmpty(fichiers) Then
        For i = 1 To UBound(fichiers)
            Debug.Print fichiers(i)
        Next
    End If
End Sub

'
' Procédure ajoutant si besoin
' le séparateur final à un nom de répertoire
' le paramètre 'Répertoire' étant passé par référence
' sa valeur est modifiée
'
Sub AjouteSéparateur(ByRef Répertoire As String)
    If Répertoire = "" Then
        Répertoire = CurDir & Application.PathSeparator
    Else
        If Right(Répertoire, 1) <> Application.PathSeparator Then
            Répertoire = Répertoire & Application.PathSeparator
        End If
    End If
End Sub
'
' Function renvoyant un tableau des noms de fichier d'un répertoire
' Paramètre AvecRépertoire: préfixe (par défaut) les noms de fichier par le nom du répertoire.
' Paramètre 'Filtre' permet de ne renvoyer que les fichiers y répondant
' par exemple pour les fichiers excel > 2003 avec ou sans macro:  Filtre = "xls?"
'
Function ListeFichiers(ByVal Répertoire As String, _
                Optional ByVal Filtre As String = ".", _
                Optional ByVal AvecRépertoire As Boolean = True) As Variant
          
    Dim item As String
    Dim i As Long
    Dim res() As String
    AjouteSéparateur Répertoire
    item = Dir(Répertoire & Filtre)
    Do While item <> ""
        i = i + 1
        ReDim Preserve res(1 To i)
        res(i) = Array(item, Répertoire & item)(-AvecRépertoire)
        item = Dir
    Loop
    ListeFichiers = Array(Empty, res)(-(i > 0))
End Function
'
' Fonction renvoyant un classeur dont le nom est passé en paramètre
' S'il n'est pas ouvert, la fonction tentera de l'ouvrir à partir
' du répertoire donné
'
Function OuvrirClasseur(ByVal NomClasseur As String, ByVal Répertoire As String) As Workbook
    AjouteSéparateur Répertoire
    On Error Resume Next
    Set OuvrirClasseur = Workbooks(NomClasseur)
    If OuvrirClasseur Is Nothing Then Set OuvrirClasseur = Workbooks.Open(Répertoire & NomClasseur)
    On Error GoTo 0
FIN:
End Function

Bonne programmation

Merci beaucoup pour tous ces enseignements.