Tableau récap feuilles différentes

**Aurianelm** · 21/06/2013, 14h08

Bonjour à tous !

Je dispose de 3 feuilles nommées par exemple "toto", "tata" et "titi".
Dans la colonne A sont répertoriées les fonctions commerciales (pour les 3 feuilles), il existe des fonctions communes aux 3 et d'autres non.
Elles ont le même nombre de colonnes mais le nombre de lignes change.

Je souhaite faire un seul tableau avec le contenu des 3 feuilles décrites précédemment, qui sera en fait la somme des 3.

Il faut donc que la macro repère lorsque la fonction est la même et là elle fait la somme sinon elle ajoute une ligne avec la nouvelle fonction.

Exemple :

Feuille "toto" :

fonc1 10 23 12 48
fonc32 20 60 40 50
fonc45 56 54 687 486
fonc2 5 60 10 2

Feuille "tata" :

fonc4 25 46 78 52
fonc32 10 20 40 20
fonc2 4 20 10 5

Je souhaite donc que dans le tableau récap on retrouve :

fonc1 10 23 12 48
fonc4 25 46 78 52
fonc32 30 80 80 70
fonc45 56 54 687 486
fonc2 9 80 20 7

Je ne sais pas du tout comment m'y prendre..Merci d'avance pour votre aide!

**EngueEngue** · 21/06/2013, 14h19

Facile

Flemme de refaire ton fichier envoi le

**Aurianelm** · 21/06/2013, 14h54

Merci ! Le voici !

**EngueEngue** · 21/06/2013, 15h06

Ok voilà le code.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub tutu()
Dim i As Long, j As Long, k As Long, l As Long
Dim existe As Boolean
 
Feuil4.Cells(1, 1) = Sheets(1).Cells(1, 1)
For i = 1 To 3
    For j = 1 To Sheets(i).Range("A1").End(xlDown).Row
        k = 1
        existe = False
        While Feuil4.Cells(k, 1) <> Empty
            If Sheets(i).Cells(j, 1) = Sheets(4).Cells(k, 1) Then
                existe = True
            End If
            k = k + 1
        Wend
        If existe = False Then
            Sheets(4).Cells(k, 1) = Sheets(i).Cells(j, 1)
        End If
    Next j
Next i
 
For i = 1 To Sheets(4).Range("A1").End(xlDown).Row
    For j = 1 To 3
        For k = 1 To Sheets(j).Range("A1").End(xlDown).Row
            For l = 2 To Sheets(j).Range("A1").End(xlToRight).Column
                If Sheets(4).Cells(i, 1) = Sheets(j).Cells(k, 1) Then
                    Sheets(4).Cells(i, 2) = Sheets(4).Cells(i, 2) + Sheets(j).Cells(k, l)
                End If
            Next l
        Next k
    Next j
Next i
 
End Sub

Adapté à ton deuxième fichier Voila:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub tutu()
Dim i As Long, j As Long, k As Long, l As Long
Dim existe As Boolean
 
Feuil9.Cells(4, 1) = Sheets(2).Cells(4, 1)
For i = 2 To 8
    For j = 4 To Sheets(i).Range("A3").End(xlDown).Row
        k = 4
        existe = False
        While Sheets(9).Cells(k, 1) <> Empty
            If Sheets(i).Cells(j, 1) = Sheets(9).Cells(k, 1) Then
                existe = True
            End If
            k = k + 1
        Wend
        If existe = False Then
            Sheets(9).Cells(k, 1) = Sheets(i).Cells(j, 1)
        End If
    Next j
Next i
 
For i = 4 To Sheets(9).Range("A3").End(xlDown).Row
    For j = 2 To 8
        For k = 4 To Sheets(j).Range("A3").End(xlDown).Row
            For l = 2 To 5
                If Sheets(9).Cells(i, 1) = Sheets(j).Cells(k, 1) And Sheets(9).Cells(3, l) = Sheets(j).Cells(3, l) Then
                    Sheets(9).Cells(i, l) = Sheets(9).Cells(i, l) + Sheets(j).Cells(k, l).Value
 
                End If
            Next l
        Next k
    Next j
Next i
 
End Sub

Fonction commerciale Nb ETP 2012 Nb Pers. Phys. 2012 Nb ETP 2013 Nb Pers. Phys. 2013
CDD COMMERCIAL FINANCIER 0 0 2 1
CONSEILLER FINANCIER 55,99926758 58 47,19970703 24
CONSEILLER GESTION PATRIMOINE 32 32 40 20
RESP EQUIPE CO EPARGNE BANQUE 10 10 10 5

Les premiers résultats

**Aurianelm** · 21/06/2013, 15h34

Merci mais il y a un bug et je ne vois pas d'où ça vient. Il dit que l'indice n'appartient pas à la sélection. Voici mon code complet (car le fichier que je t'ai envoyé est créé par un code vba déjà). Ton code est à la fin (appelé dir_com), je l'appelle dans le 1er code Eclatement().

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
Option Explicit
 
Sub Eclatement()
Dim LastLig As Long, i As Long
Dim Wbk As Workbook
Dim Tb
Dim chemin As String
 
chemin = "G:\DTRC\Administration des ventes\ADV _ ADV\EQUIPE\Auriane\Suivi des ept réseau commercial\"
 
Workbooks.Open Filename:=chemin & "Maquette ETP.xls"
 
Application.ScreenUpdating = False
Codes Tb
With ThisWorkbook.Worksheets("ETP_Réseau_commercial")
    .AutoFilterMode = False
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
 
    Set Wbk = Workbooks("Maquette ETP.xls")
 
    For i = 0 To UBound(Tb)
        .Range("A1:A" & LastLig).AutoFilter Field:=1, Criteria1:=Tb(i)
        Transfer Wbk, .Range("B2:F" & LastLig), Tb(i)
        .AutoFilterMode = False
    Next i
End With
 
Call dir_com
 
Wbk.Sheets("Feuil1").Visible = False
Wbk.SaveAs Filename:=chemin & "Suivi des ept réseau commercial.xls"
 
End Sub
 
Private Sub Codes(ByRef Tb)
Dim LastLig As Long, i As Long
Dim Dico As Object
 
With ThisWorkbook.Worksheets("ETP_Réseau_commercial")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set Dico = CreateObject("Scripting.dictionary")
    Tb = .Range("A2:A" & LastLig)
    For i = 1 To LastLig - 1
        If Not Dico.exists(Tb(i, 1)) Then Dico.Add Tb(i, 1), ""
    Next i
    Erase Tb
    Tb = Dico.keys
    Set Dico = Nothing
End With
End Sub
 
Private Sub Transfer(ByVal Wbk As Workbook, ByVal Rng As Range, ByVal Nom As String)
Dim Ws As Worksheet
Dim derligne As Integer, i As Integer
 
If existe(Wbk, Nom) Then
    Set Ws = Wbk.Worksheets(Nom)
    Ws.UsedRange.Offset(3).Clear
Else
    Set Ws = Wbk.Worksheets.Add(After:=Wbk.Sheets(1))
    Ws.Name = Nom
End If
Rng.SpecialCells(xlCellTypeVisible).Copy
Ws.Range("A4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Set Ws = Nothing
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("A1") = Nom
Workbooks("Maquette ETP.xls").Sheets(Nom).Columns("A:A").EntireColumn.AutoFit
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("B:B,D:D").Select
Selection.NumberFormat = "0.00"
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("A3").Value = "Fonction commerciale"
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("B3").Value = "Nb ETP 2012"
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("C3").Value = "Nb Pers. Phys. 2012"
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("D3").Value = "Nb ETP 2013"
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("E3").Value = "Nb Pers. Phys. 2013"
Workbooks("Maquette ETP.xls").Sheets(Nom).Columns("B:B").EntireColumn.AutoFit
Workbooks("Maquette ETP.xls").Sheets(Nom).Columns("C:C").EntireColumn.AutoFit
Workbooks("Maquette ETP.xls").Sheets(Nom).Columns("D:D").EntireColumn.AutoFit
Workbooks("Maquette ETP.xls").Sheets(Nom).Columns("E:E").EntireColumn.AutoFit
Workbooks("Maquette ETP.xls").Sheets(Nom).Range("A1").Select
With Selection.Interior
    .ColorIndex = 6
    .Pattern = xlSolid
End With
Selection.Font.Bold = True
With Selection
    .HorizontalAlignment = xlCenter
End With
 
derligne = Range("A65000").End(xlUp).Row
 
'Calcul de l'évolution
 
Range("F3").Value = "Evolution nb ETP"
Range("G3").Value = "Evolution nb Pers. Phys."
Range("F4").Select
 
For i = 4 To derligne
    Range("F" & i).FormulaR1C1 = "=IF(RC[-4]=0,"" "",((RC[-2]-RC[-4])/RC[-4])*100)"
    Range("G" & i).FormulaR1C1 = "=IF(RC[-4]=0,"" "",((RC[-2]-RC[-4])/RC[-4])*100)"
    Range("F" & i & ": G" & i).NumberFormat = "0.00"
Next
 
Range("A3:G" & derligne).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
Range("A3:A" & derligne).Select
Selection.Font.Bold = True
Range("A3:G3").Select
Selection.Font.Bold = True
Workbooks("Maquette ETP.xls").Sheets(Nom).Columns("F:F").EntireColumn.AutoFit
Workbooks("Maquette ETP.xls").Sheets(Nom).Columns("G:G").EntireColumn.AutoFit
Range("F4:G" & derligne).FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
        Formula1:="0"
    Range("F4:G" & derligne).FormatConditions(1).Font.ColorIndex = 3
    Range("F4:G" & derligne).FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="0"
    Range("F4:G" & derligne).FormatConditions(2).Font.ColorIndex = 10
End Sub
 
Private Function existe(ByVal Wbk As Workbook, ByVal Nom As String) As Boolean
 
On Error Resume Next
existe = Wbk.Sheets(Nom).Index
End Function
 
Sub dir_com()
Dim i As Long, j As Long, k As Long, l As Long
Dim existe As Boolean
 
Sheets("Feuil9").Cells(4, 1) = Sheets(2).Cells(4, 1)
For i = 2 To 8
    For j = 4 To Sheets(i).Range("A3").End(xlDown).Row
        k = 4
        existe = False
        While Sheets(9).Cells(k, 1) <> Empty
            If Sheets(i).Cells(j, 1) = Sheets(9).Cells(k, 1) Then
                existe = True
            End If
            k = k + 1
        Wend
        If existe = False Then
            Sheets(9).Cells(k, 1) = Sheets(i).Cells(j, 1)
        End If
    Next j
Next i
 
For i = 4 To Sheets(9).Range("A3").End(xlDown).Row
    For j = 2 To 8
        For k = 4 To Sheets(j).Range("A3").End(xlDown).Row
            For l = 2 To 4
                If Sheets(9).Cells(i, 1) = Sheets(j).Cells(k, 1) And Sheets(9).Cells(3, l) = Sheets(j).Cells(3, l) Then
                    Sheets(9).Cells(i, l) = Sheets(9).Cells(i, l) + Sheets(j).Cells(k, l).Value
 
                End If
            Next l
        Next k
    Next j
Next i
 
End Sub

**EngueEngue** · 21/06/2013, 15h37

Haha il faut créer une feuille pour stocker le tableau récapitulatif. J'avais oublié de mettre le la boucle for l = 2 à 5 j'ai remodifié le code.

Si j'ai bien compris tu voulais avoir ton tableau récap dans le feuille 1...
Change tous les sheets(9) par des sheets(1)

Tableau récap feuilles différentes [Toutes versions]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager