VBA Réaliser la somme de cellules dans des fichiers différents

Question

Bonjour,

J'ai une cinquantaine de fichiers construits exactement de la même façon avec des données. Je souhaiterais les intégrer dans un fichier de synthèse (tableau identique à celui des autres fichiers).
J'arrive à l'aide d'une macro (ci-dessous) à faire la somme d'une cellule dans tous les fichiers mais je n'arrive pas à enchainer pour réaliser la somme des autres cellules contenues dans le tableau. Petite précision : c'est un tableau à 20 colonnes et 18 lignes qu'il faudrait synthétiser.

Est-ce quelqu'un pourrait m'aider à trouver l'astuce ?

Merci d'avance!!! 


Sub sommescellule()
Dim objShell As Object, objFolder As Object
Dim Chemin As String, fichier As String
Dim compteur As String

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, ThisWorkbook.Path)

If objFolder Is Nothing Then
    MsgBox "Arret de la macro", vbCritical, "Annulation"
Else
    'On renseigne le compteur à 0
    compteur = 0
    'Sélection du répertoire
    Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
    
    'format du fichier (par exemple xlsx)
    fichier = Dir(Chemin & "*.xlsm")
    Do While Len(fichier) > 0
        If fichier <> ThisWorkbook.Name Then
            'la cellule qui va être recherchée dans les autres classeurs est C36 de la feuille 1
            ThisWorkbook.Names.Add "Plage", _
            RefersTo:="='" & Chemin & "[" & fichier & "]'xxxxxx'!$C$36"
            'on va coller le résultat dans la feuille 2
            With Sheets("Feuil2")
                .[A1] = "=Plage"
                'on ajoute le résultat trouvé dans le compteur
                compteur = compteur + .[A1].Value
                nbr = nbr + 1
            End With
        End If
        fichier = Dir()
        
        Loop
End If

'On colle le compteur dans la cellule C36
Range("C11").Select
ActiveCell.Value = compteur / nbr

End Sub
        EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI 

Merci d'y penser dans tes prochains messages.

f894009 · Answer

Bonjour,

A voir pour adapter la plage, le nom de feuille

'base de codage: http://silkyroad.developpez.com/VBA/ClasseursFermes/
'Changement de mode de connexion aux fichiers fermes
Sub Requete_lecture_ClasseurFerme_Excel2007_201x()
    Dim objShell As Object, objFolder As Object, Cn As Object, Rst As Object
    Dim Chemin As String, Fichier As String
    Dim NomFeuille As String, texte_SQL As String
    Dim Table_Cumul(17, 19) As Single       'Tabel de cumul des valeurs

Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, ThisWorkbook.Path)

If objFolder Is Nothing Then
        MsgBox "Arret de la macro", vbCritical, "Annulation"
    Else
        'Sélection du répertoire
        Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
        'format du fichier (par exemple xlsx)
        Fichier = Dir(Chemin & "*.xlsx")
        Do While Len(Fichier) > 0
            'Nom de la feuille dans le classeur fermé
            NomFeuille = "FTest"
            Set Cn = CreateObject("ADODB.Connection")
            Set Rst = CreateObject("ADODB.Recordset")
            'connexion fichier ferme
            With Cn
                .ConnectionString = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & Chemin & Fichier
                .Open
            End With
            'requete SQL pour une plage de cellules
            texte_SQL = "SELECT * FROM [" & NomFeuille & "$C35:V40]"
            'lecture plage de cellules
            Set Rst = CreateObject("ADODB.Recordset")
            Set Rst = Cn.Execute(texte_SQL)
            '------------Cumul valeurs par cellule----------------
            x = 0
            'boucle sur les enregistrements a lire
            Do While Not Rst.EOF
                'boucle sur les champs de l'enregistrement en cours de lecture
                For i = 0 To Rst.Fields.Count - 1
                    Table_Cumul(x, i) = Table_Cumul(x, i) + Rst.Fields(i).Value
                Next i
                x = x + 1
                'avance d'un enregistrement
                Rst.Movenext
            Loop
            '--- Fermeture connexion ---
            Cn.Close
            Set Cn = Nothing
            Set Rst = Nothing
            'Classeur suivant
            Fichier = Dir()
        Loop
        'ecriture dans plage feuil1
        Worksheets("Feuil1").Range("A1").Resize(18, 20) = Table_Cumul
    End If
End Sub

VBA Réaliser la somme de cellules dans des fichiers différents

1 réponse

Discussions similaires

Newsletters