Fichier Bilan sous Excel

[micdel]

Bonjour

Sous Excel 2000, je souhaite réaliser un bilan pour une association dans un fichier « Bilan_annuel », en extrayant des données saisies préalablement dans 12 fichiers mensuels fermés indicés « 2008_01.xls », « 2008_02.xls » … à … « 2008_12.xls ».

Les 13 fichiers sont dans le même répertoire.

Fichier « Bilan_annuel » :
- C1 contient le chemin du fichier ex : E:\Asso\Statistiques\2008
- C2 contient l’année de traitement ex : 2008
- Un clic, sur un bouton, lance la lecture des données mensuelles

- B10:K18 ... reçoit les données lues en D10:M18 dans « 2008_01.xls »
- B20:K28 ... reçoit les données lues en D10:M18 dans « 2008_02.xls »
- B30:K38 ... reçoit les données lues en D10:M18 dans « 2008_03.xls »
- …. jusqu'à
- B120:K128 ... reçoit les données lues en D15:M24 dans « 2008_12.xls »

Pourriez-vous m’aider dans l’écriture d’une macro qui réaliserait cette synthèse ?

 

[Guest]

Re : Fichier Bilan sous Excel

Bopnjour micdel

voici le code d'un module que j'ai écrit il y a quelques temps pour quelqu'un d'autre. J'ai tenter de l'adapter à ton cas mais sans données concrètes c'est difficile de te dire si il fonctionnera.

Il y a trois modifications à faire à coup sûr
1 - Remplacer le nom de la feuille où sont les cellules C1 et C2 qui contiennent le chemin et l'anné
2 - Remplacer le nom de la feuille source des données
2 - remplacer le nom de la feuille destination des données.

voir ci-dessous les codes couleurs où sont à faire les remplacements

Option Explicit
'necessite d'activer la reference Microsoft ActiveX Data Objects 2.x Library
'dans Outils, référence où x est un numéro de version
Dim cnx As ADODB.Connection
Function GetConnectionOk(ByVal fichier As String) As Boolean
    If Not cnx Is Nothing Then
        'Si la connexion est ouvert
        If cnx.State = adStateOpen Then cnx.Close
    End If
    Set cnx = Nothing
    If Dir(fichier) = "" Then
        MsgBox "Le fichier (" & fichier & ") n'existe pas", vbExclamation, "Connexion au fichier"
        Set cnx = New ADODB.Connection
        With cnx
            .ConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;" & _
                                "data source=" & fichier & ";" & _
                                "extended properties=""Excel 8.0;"""
            .CursorLocation = adUseClient
            .Open
            GetConnectionOk = .State = adStateOpen
        End With
    End If
End Function
Private Function GetListeFichier()
    Dim chemin As String, fichier As String
    Dim annee As Integer
    Dim idx As Byte
    Dim t(1 To 12) As String
    'Remplacer Feuil1 par le nom de la feuille idoine
    chemin = Sheets("[SIZE=3][COLOR=olive]Feuil1[/COLOR][/SIZE]").Range("C1")
    annee = Sheets("[SIZE=3][COLOR=olive]Feuil1[/COLOR][/SIZE]").Range("C2")
    If Dir(chemin) = "" Then
        MsgBox "Le répertoire (" & chemin & ") n'existe pas", vbExclamation, "Liste fichiers"
        Exit Sub
    End If
    If annee = 0 Then
        MsgBox "Mettez une année en C1", vbExclamation, "Liste fichiers"
        Exit Sub
    End If
 
    If Not Right(chemin, 1) = "\" Then chemin = chemin & "\"
 
    For i = 1 To 12
        fichier = chemin & CStr(annee) & "_" & Format(idx, "00") & ".xls"
        If Dir(fichier) <> "" Then
            t(i) = fichier
        Else
            t(i) = ""
        End If
    Next i
    GetListeFichier = t
End Function
 
Private Sub CommandButton1_Click()
    Dim rs As ADODB.Recordset
    Dim i As Byte
    Dim ligne As Long
    Dim listeFichiers
    Dim sql As String
    sql = "SELECT * FROM [Feuil1$D10:M18];"
    listeFichiers = GetListeFichier()
    ligne = 10
    For i = 1 To 12
        If i < 11 Then
            'Remplacer Feuil1 par le nom de la feuille source
            sql = "SELECT * FROM [[SIZE=3][COLOR=red]Feuil1[/COLOR][/SIZE]$D10:M18];"
        Else
            sql = "SELECT * FROM [[SIZE=3][COLOR=red]Feuil1[/COLOR][/SIZE]$D15:M24];"
        End If
        If listeFichiers(i) <> "" Then
            If GetConnectionOk(listeFichiers(i)) Then
                Set rs = New Recordset
                rs.Open sql, cnx, adOpenKeyset, adLockOptimistic
                If rs.State = adStateOpen Then
                    'Remplacer "Destination" par le nom de la feuille de réception des données
                    With Sheets("[SIZE=3][COLOR=blue]Destination[/COLOR][/SIZE]")
                        .Cells(ligne, 1).CopyFromRecordset rs
                        ligne = ligne + rs.RecordCount + 2
                    End With
                    rs.Close                          'Fermeture du recordset
                End If
                Set rs = Nothing                      'Destruction du recordset
                cnx.Close                             'Fermeture de la connexion
                Set cnx = Nothing                     'Destruction de la connexion
            End If                                    'connection
        End If                                        'Fichier
    Next i
End Sub

A bientôt

 

[micdel]

Re : Fichier Bilan sous Excel

Hasco

merci pour ta promptitude
je vais essayer apporter les modifis que tu proposes
pour l'adapter à mon cas
cordialerment
Micdel