Macro - calculs à partir d'un nombre variable de fichiers Excel et conserver le format de cellules

Version imprimable

Bonjour,

J'essaie de trouvé une solution à mon problème depuis quelques jours en consultant divers forums discussion en ligne, mais je n'y arrive pas. C'est la première fois j'écris dans un forum et je vais essayer d'expliquer le plus clairement possible.

J'ai trois fichiers Excel: "Tableau de bord sommaire", "Entrée de données1" et "Entrée de données2". Dans chaque fichier d'entrée de données, on retrouve une liste d'indicateurs et pour chacun de ces indicateurs, il y a une cellule pour le numérateur et une cellule pour le dénominateur où les usagers peuvent inscrire les données pour chaque mois.

J’ai utilisé une macro dans le fichier Excel « TABLEAU DE BORD SOMMAIRE » pour faire la somme des cellules H2 des fichiers « Entrée de données 1 » et « Entrée de données 2 » divisé par la somme des cellules H3 des fichiers « Entrées de données 1 » et « Entrée de données 2 ». Le résultat s’affiche dans la cellule A1 de la feuille 2 (sheet2) du fichier « TABLEAU DE BORD SOMMAIRE ».

Voici l'équation : (H2 Entrées des données1+H2 Entrées des données2)/(H3 Entrées des données1+H3 Entrées des données2)=Résultat dans A1 feuille2 du fichier "TABLEAU DE BORD SOMMAIRE"

La macro que j'ai utilisé est la suivante:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub CopySommaire() Dim currentSheet As Worksheet Dim sheetIndex As Integer sheetIndex = 1 Chemin1 = Range("B20").Value Chemin2 = Range("B23").Value Fichier1 = Range("B25").Value Fichier2 = Range("B26").Value Set wkbSource = Workbooks.Open(Chemin1) Set wkbSource = Workbooks.Open(Chemin2) Windows(Fichier1).Activate Windows(Fichier2).Activate Workbooks("TABLEAU DE BORD SOMMAIRE").Worksheets(2).Range("A1").Value = (Workbooks(Fichier1).Worksheets("Entrée Indicateur du service").Range("H2") + Workbooks(Fichier2).Worksheets("Entrée Indicateur du service").Range("H2")) / (Workbooks(Fichier1).Worksheets("Entrée Indicateur du service").Range("H3") + Workbooks(Fichier2).Worksheets("Entrée Indicateur du service").Range("H3")) End Sub
La macro fonctionne, mais je dois maintenant la modifier pour pouvoir l'adapter à différents nombres de fichiers d'entrées de données. Chaque fichier d'entrée de données représente un service et chaque directeurs de la compagnie où je travaille peut avoir un nombre différents de services sous sa responsabilité et donc un nombre différents de fichiers d'entrées de données. Je veux pouvoir calculer la formule suivante:

(H2 Entrées des données1+H2 Entrées des données2+⋯+H2 Entrées des données n)/(H3 Entrées des données1+H3 Entrées des données2+⋯+H3 Entrée des données n)

À noter que j'ai nommé mes fichiers « Entrée de données 1 » et « Entrées de données 2 » pour l’exercice, mais les noms des fichiers sont inconnus parce que chaque directeur peut nommer ses fichiers comme il le veut. Pour cette raison, j'ai utilisé une macro associé à un bouton que l'usager peut cliquer et le chemin d'accès (path) s'affiche dans une cellule et le nom du fichier en question s'affiche dans une autre cellule. Ça permet d'identifier les fichiers en questions, mais mon problème est qu'il y a un nombre de fichiers d'entrées de données variable selon les directeurs et je n'arrive pas à adapter la macro pour faire ça.

Une fois que la macro va fonctionner H2/H3, il faudra répéter la formule pour toutes les cases du tableau des fichiers d'entrées de données. Tous les fichiers d'entrées de données ont un tableau identique.

De plus, je cherche une méthode de conserver le format ($, %, 1 décimal, 2 décimales, etc.) de la ligne du numérateur et si possible quand le numérateur et dénominateurs sont des nombres, donner le résultat en pourcentage. Exemple : numérateur Entrées de données1=4, dénominateur Entrées de données2=2, dénominateur Entrée de données1=3, dénominateur Entrée de données2=7.
(4+2)/(3+7)=60%

Est-ce que quelqu'un peut me donner des pistes de solution?

* Merci *

Un exemple en utilisant la méthode GetOpenFilename avec Multiselect (choix multiple de tes fichiers)
Les données de H2 et H3 de chaque fichier sont ajouté aux variables N et D (attention quand même aux types de données de H2 et H3)
La feuille Entrée Indicateur du service doit exister dans tous les fichiers

Attention code fragile

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Option Explicit
 
Sub CopySommaire()
Dim N As Double, D As Double
Dim Wbk As Workbook
Dim i As Integer
Dim Fichiers
 
Application.ScreenUpdating = False
 
Fichiers = Application.GetOpenFilename("Excel Files (*.xls*), *.xls", Title:="Choix des fichiers", MultiSelect:=True)
If IsArray(Fichiers) Then
    For i = 1 To UBound(Fichiers)
        Set Wbk = Workbooks.Open(Fichiers(i), ReadOnly:=True)
        With Wbk.Worksheets("Entrée Indicateur du service")
            N = N + .Range("H2")
            D = D + .Range("H3")
        End With
        Wbk.Close False
        Set Wbk = Nothing
    Next i
End If
 
With ThisWorkbook.Worksheets(2).Range("A1")
    .ClearContents
    If D <> 0 Then
        .Value = N / D
        .NumberFormat = "0.0%"
    End If
End With
End Sub

30/08/2014, 18h52
Lune1

Merci pour la réponse rapide

Merci pour la réponse.:P La sélection des fichiers multiples fonctionne bien. Le calcul et le format en pourcentage aussi. Je me demandais s'il serait possible de garder le format en pourcentage lorsque les numérateur sont des entiers et sinon conserver le format de cellule.

Exemples:
Si H2 Entrée de données1=2, H2Entrée de données2=3, H3 Entrée de données1=4, H3 Entrée de données2=5, alors le résultat est en pourcentage (2+3)/(4+5)=55.55% (résultat en pourcentage car numérateurs sans unités, pas de %, $ ou autres).

Si numérateurs H2 Entrée de données1=20$, H2Entrée de données2=30$, H3 Entrée de données1=4, H3 Entrée de données2=5 Alors, (2$+3$)/(4+5)=0,55$ (résultat en dollars car numérateurs en dollars). Le format de cellule de numérateur est conservé.

Difficile de cerner tous les cas de figures, mais pour le format monétaire, on peut prévoir ce cas sinon, on aura un pourcentage.

J'espère que vous aviez compris le code, pour passer à une étape suivante: vérifier l'existence de la feuille.

Dans la prochaine étape on pourra vérifier que H2 et H3 contiennent bien des nombres.

A toi

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Sub CopySommaire()
Dim N As Double, D As Double
Dim Feuille As String
Dim Wbk As Workbook
Dim Cur As Boolean
Dim i As Integer
Dim Fichiers
 
Application.ScreenUpdating = False
 
Fichiers = Application.GetOpenFilename("Excel Files (*.xls*), *.xls", Title:="Choix des fichiers", MultiSelect:=True)
If IsArray(Fichiers) Then
    Feuille = "Entrée Indicateur du service"
    For i = 1 To UBound(Fichiers)
        Set Wbk = Workbooks.Open(Fichiers(i), ReadOnly:=True)
        If SheetExist(Wbk, Feuille) Then
            With Wbk.Worksheets(Feuille)
                If InStr(.Range("H2").NumberFormat, "$") Then Cur = True
                N = N + .Range("H2")
                D = D + .Range("H3")
            End With
        Else
            MsgBox "La feuille [" & Feuille & "] n'existe pas dans le classeur " & Wbk.Name
        End If
        Wbk.Close False
        Set Wbk = Nothing
    Next i
 
    With ThisWorkbook.Worksheets(2).Range("A1")
        .ClearContents
        If D <> 0 Then
            .Value = N / D
            .NumberFormat = "0.00" & IIf(Cur, "$", "%")
        End If
    End With
Else
    MsgBox "Opération annulée, aucun fichier n'est sélectionné"
End If
End Sub
 
'Fonction qui permet de vérifier l'existence d'une feuille nommée ShName dans le classeur Wb
Private Function SheetExist(ByVal Wb As Workbook, ByVal ShName As String) As Boolean
 
On Error Resume Next
SheetExist = Wb.Sheets(ShName).Index
End Function

Bonjour,
Pour vérifier si H2 et H3 contiennent bien des nombres, j’ai ajouté ces trois lignes :

Code:

1
2
3
With Range("H2" & "H3")
        If Not Numeric("H2" & "H3") Then MsgBox "Entrée non numérique."
End With

Le code complet devient donc :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Option Explicit
 
Sub CopySommaire()
Dim N As Double, D As Double
Dim Feuille As String
Dim Wbk As Workbook
Dim Cur As Boolean
Dim i As Integer
Dim Fichiers
Dim Numeric As Double
 
Application.ScreenUpdating = False
 
Fichiers = Application.GetOpenFilename("Excel Files (*.xls*), *.xls", Title:="Choix des fichiers", MultiSelect:=True)
If IsArray(Fichiers) Then
    Feuille = "Entrée Indicateur du service"
    With Range("H2" & "H3")
        If Not Numeric("H2" & "H3") Then MsgBox "Entrée non numérique."
    End With
    For i = 1 To UBound(Fichiers)
        Set Wbk = Workbooks.Open(Fichiers(i), ReadOnly:=True)
        If SheetExist(Wbk, Feuille) Then
            With Wbk.Worksheets(Feuille)
                If InStr(.Range("H2").NumberFormat, "$") Then Cur = True
                N = N + .Range("H2")
                D = D + .Range("H3")
            End With
        Else
            MsgBox "La feuille [" & Feuille & "] n'existe pas dans le classeur " & Wbk.Name
        End If
        Wbk.Close False
        Set Wbk = Nothing
    Next i
 
    With ThisWorkbook.Worksheets(2).Range("A1")
        .ClearContents
        If D <> 0 Then
            .Value = N / D
            .NumberFormat = "0.00" & IIf(Cur, "$", "%")
        End If
    End With
Else
    MsgBox "Opération annulée, aucun fichier n'est sélectionné"
End If
End Sub
 
'Fonction qui permet de vérifier l'existence d'une feuille nommée ShName dans le classeur Wb
Private Function SheetExist(ByVal Wb As Workbook, ByVal ShName As String) As Boolean
 
On Error Resume Next
SheetExist = Wb.Sheets(ShName).Index
End Function

Mais ça ne fonctionne pas. J’ai bien peur de ne pas comprendre. Je commence tout juste avec le VBA.

Pour la partie de vérifier l’existence de la feuille, est que la ligne suivante fait déjà la vérification?

Code:

SheetExist = Wb.Sheets(ShName).Index

Pour conserver le format des cellules, si je renonce au format pourcentage,…
au lieu de (4+2)/(3+7)=60%,
j’aurais (4+2)/(3+7)=0.60
Est-ce qu’il y a moyen de conserver le format des cellules en tout temps? J’ai vu dans des discussions en ligne que c’est possible lorsqu’on fait un copier-coller, mais mon cas, c’est une formule.

31/08/2014, 18h16
mercatog

vba ou autre langage n'est pas du traitement de texte. Je te laisse apprendre les bases pour continuer

Mieux s'abstenir que d'écrire des bêtise tel Range("H2"&"H3") ou numeric("H3" &"H3")

Quand tu auras les bases élémentaires, reviens ici pour une question précise.