L'aide pour rajouter le code VBA

**Gogia** · 29/08/2011, 11h48

Bonjour le forum,
La situation est la suivante :
Il y a un fichier « BDC macros » qui possède une macro « consolide ». En appuyant sur le bouton la macro :
1. Ouvre le fichier « BD consolidées », vérifie s’il n’y a pas des doublons et recopie les données du fichier « BDC macros » sur ce fichier.
2. Ouvre le fichier « BD d’équipe 1», vérifie s’il n’y a pas des doublons et recopie les données du fichier « BDC macros » sur ce fichier.

Je voudrais demander l’aide d’un spécialiste de VBA pour rajouter le code pour que cette macro puisse exécuter aussi:

1. Mettre à jour de tableaux croisés dynamiques. Il y a un TCD dans chaque de fichiers « BD consolidées » et « BDC macros ».
2. Sauvegarder les changements faits sur ces deux fichiers.
3. Fermer ces deux fichiers.

D’avance merci pour votre assistance !

Voici 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
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
Sub consolide()
    Dim WbkMaitre As Workbook, WbkConso As Workbook
    Dim nbLign As Long, derLign&, doublon&, i&, derLignC&, derLignA&
    Dim TblCde
    Dim repertoire As String
    Dim cel As Range, trouve As Range
 
    Application.ScreenUpdating = False
    'classeur maître : Fichier contenant le bon de commande
    Set WbkMaitre = ThisWorkbook
    repertoire = "gestion:Dépenses:" 'mettre le chemin du répertoire contenant les BD ici, laisser le ":" à la fin
    'If Left(CurDir, 1) <> Left(repertoire, 1) Then ChDrive Left(repertoire, 1) & ":": ChDir repertoire
    'classeur cible 1 : Fichier de commandes consolidées
    'ChDir repertoire
    'Workbooks.Open repertoire & "BD consolidées.xls"
    Workbooks.Open "gestion:Dépenses:BD consolidées.xls", Updatelinks:=False
    Set WbkConso = ActiveWorkbook
 
 
    With WbkMaitre.Sheets("Commande")
'compte le nombre de ligne de commande
nbLign = .Application.WorksheetFunction.Count(.Range("C:C"))
 
'si le nombre de ligne est nul on sort de la macro
If nbLign = 0 Then MsgBox "La commande ne comporte aucune ligne": Exit Sub
    Set TblCde = .[C3].Resize(nbLign, 24)
    End With
    With WbkConso
.Activate
With .Sheets("Data")
      derLign = .Range("C" & Rows.Count).End(xlUp).Row + 1
        .Range("C" & derLign).Resize(nbLign, 24).Value = TblCde.Value
        TblCde.Copy
        .Range("C" & derLign).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
 'suppression des doublons
        For Each cel In .Range("C" & derLign).Resize(nbLign)
        doublon = Evaluate("SumProduct((" & .Range("C3:C" & derLign - 1).Address & "=" & cel.Value & ")*(" & .Range("D3:D" & derLign - 1).Address & "=" & cel.Offset(, 1).Value & "))")
        If doublon > 0 Then Cells(cel.Row, 1).Value = "$$$"
            Next cel
                Set trouve = .Range("A" & derLign).Resize(nbLign).Find("$$$", LookAt:=xlWhole)
                If Not trouve Is Nothing Then
                For i = nbLign + derLign - 1 To derLign Step -1
                If .Cells(i, 1) = "$$$" Then .Rows(i).Delete
                Next i
            End If
        derLignC = .Range("C" & Rows.Count).End(xlUp).Row
        derLignA = IIf(.Range("A" & Rows.Count).End(xlUp).Row + 1 < 3, 3, .Range("A" & Rows.Count).End(xlUp).Row + 1)
        If derLignC > derLignA Then
        For i = derLignA To derLignC
 .Cells(i, 1) = .Cells(i - 1, 1) + 1
                 Next i
            End If
        End With
   '.Close
End With
 
        With WbkMaitre
            .Activate
            a = .Sheets("Commande").Range("c3").Resize(nbLign).Value
            lim = UBound(a)
        ReDim temp(1 To lim, 1 To 1)
            k = 1
            cpt = 0
                temp(1, 1) = a(1, 1)
        For i = 1 To lim
        For j = 1 To lim
    If a(i, 1) = temp(j, 1) Then Exit For
                cpt = cpt + 1
        Next j
    If cpt = lim Then k = k + 1: temp(k, 1) = a(i, 1)
     cpt = 0
        Next i
        For i = 1 To k
        Call Cde_Equip(WbkMaitre, .Sheets("Commande"), repertoire, temp(i, 1))
        Next i
    End With
End Sub
 
Sub Cde_Equip(Maitre As Workbook, FeuilBase As Worksheet, ByVal rep As String, ByVal numEquip As Long)
Dim nbLign As Long, derLign&, i&, derLignA&, derLignC&
Dim trouve As Range, plageEquip As Range
FeuilBase.Copy before:=Maitre.Sheets(1)
With ActiveSheet
.Range("C3:Z45").Sort Key1:=.Range("C3"), Order1:=xlAscending, Key2:=.Range("D3") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
nbLign = Application.CountIf(.Range("C3:C45"), numEquip)
Set trouve = .Range("C2:C45").Find(numEquip, LookIn:=xlValues, LookAt:=xlWhole)
Set plageEquip = trouve.Resize(nbLign, 24)
Set ExistFichier = Nothing
On Error Resume Next
Set ExistFichier = Workbooks.Open(rep & "BD d'équipe " & numEquip & ".xls", Updatelinks:=False)
On Error GoTo 0
If ExistFichier Is Nothing Then
MsgBox "L'équipe " & numEquip & " n'a pas de fichier." & vbCrLf & _
"Veuillez en créer un.", vbExclamation
Exit Sub
End If
 
Sheets("Data").Select
plageEquip.Copy
derLign = IIf(Range("C" & Rows.Count).End(xlUp).Row + 1 < 3, 3, Range("C" & Rows.Count).End(xlUp).Row + 1)
With Cells(derLign, 3)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
'suppression des doublons
Columns(3).Insert xlToRight
For Each cel In Range("D" & derLign).Resize(nbLign)
doublon = Evaluate("SumProduct((" & Range("D3:D" & derLign - 1).Address & "=" & cel.Value & ")*(" & Range("E3:E" & derLign - 1).Address & "=" & cel.Offset(, 1).Value & "))")
If doublon > 0 Then Cells(cel.Row, 3).Value = "$$$"
Next cel
Set trouve = Range("C" & derLign).Resize(nbLign).Find("$$$", LookAt:=xlWhole)
If Not trouve Is Nothing Then
For i = nbLign + derLign - 1 To derLign Step -1
If Cells(i, 3) = "$$$" Then Rows(i).Delete
Next i
End If
Columns(3).Delete
derLignC = Range("C" & Rows.Count).End(xlUp).Row
derLignA = IIf(Range("A" & Rows.Count).End(xlUp).Row + 1 < 3, 3, Range("A" & Rows.Count).End(xlUp).Row + 1)
If derLignC > derLignA Then
For i = derLignA To derLignC
Cells(i, 1) = Cells(i - 1, 1) + 1
Next i
End If
Application.DisplayAlerts = False
.Delete
End With
End Sub

**Philippe Tulliez** · 29/08/2011, 12h25

Bonjour,
Pour la question

1. Mettre à jour de tableaux croisés dynamiques. Il y a un TCD dans chaque de fichiers « BD consolidées » et « BDC macros ».

Tu peux utiliser ThisWorkbook.RefreshAll, si les macros sont dans le classeur où se trouve les TCD, dans le cas contraire il faut l'adapter.

[EDIT] Je viens de voir que c'était pour MAC, le code donné ici a été testé sur Excel 2010 (Windows XP)

**Gogia** · 31/08/2011, 15h07

Corona,
Oui, je travaile sur MAC.
Il y a une seule macro dans le fichier 1 et les TCD se trouvent dans les fichiers 2 & 3. Le problème le plus important est que je suis nul dans le VB. Je suis capable de comprendre quoi fait le code (même pas tojours). Par contre, je ne sais pas écrire le code

C'est pourquoi je m'adresse au forum avec ma demande.

Bonjour,

J'ai trouvé déjà la solution (les lignes 136-148)

Merci

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
Sub consolide()
    Dim WbkMaitre As Workbook, WbkConso As Workbook
    Dim nbLign As Long, derLign&, doublon&, i&, derLignC&, derLignA&
    Dim TblCde
    Dim repertoire As String
    Dim cel As Range, trouve As Range
 
    Application.ScreenUpdating = False
    'classeur maître : Fichier contenant le bon de commande
    Set WbkMaitre = ThisWorkbook
    repertoire = "gestion:Dépenses:" 'mettre le chemin du répertoire contenant les BD ici, laisser le ":" à la fin
    'If Left(CurDir, 1) <> Left(repertoire, 1) Then ChDrive Left(repertoire, 1) & ":": ChDir repertoire
    'classeur cible 1 : Fichier de commandes consolidées
    'ChDir repertoire
    'Workbooks.Open repertoire & "BD consolidées.xls"
    Workbooks.Open "gestion:Dépenses:BD_consolidees.xls", Updatelinks:=False
    Set WbkConso = ActiveWorkbook
 
 
    With WbkMaitre.Sheets("Commande")
'compte le nombre de ligne de commande
nbLign = .Application.WorksheetFunction.Count(.Range("C:C"))
 
'si le nombre de ligne est nul on sort de la macro
If nbLign = 0 Then MsgBox "La commande ne comporte aucune ligne": Exit Sub
    Set TblCde = .[C3].Resize(nbLign, 24)
    End With
    With WbkConso
.Activate
With .Sheets("Data")
      derLign = .Range("C" & Rows.Count).End(xlUp).Row + 1
        .Range("C" & derLign).Resize(nbLign, 24).Value = TblCde.Value
        TblCde.Copy
        .Range("C" & derLign).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
 'suppression des doublons
        For Each cel In .Range("C" & derLign).Resize(nbLign)
        doublon = Evaluate("SumProduct((" & .Range("C3:C" & derLign - 1).Address & "=" & cel.Value & ")*(" & .Range("D3:D" & derLign - 1).Address & "=" & cel.Offset(, 1).Value & "))")
        If doublon > 0 Then Cells(cel.Row, 1).Value = "$$$"
            Next cel
                Set trouve = .Range("A" & derLign).Resize(nbLign).Find("$$$", LookAt:=xlWhole)
                If Not trouve Is Nothing Then
                For i = nbLign + derLign - 1 To derLign Step -1
                If .Cells(i, 1) = "$$$" Then .Rows(i).Delete
                Next i
            End If
        derLignC = .Range("C" & Rows.Count).End(xlUp).Row
        derLignA = IIf(.Range("A" & Rows.Count).End(xlUp).Row + 1 < 3, 3, .Range("A" & Rows.Count).End(xlUp).Row + 1)
        If derLignC > derLignA Then
        For i = derLignA To derLignC
 .Cells(i, 1) = .Cells(i - 1, 1) + 1
                 Next i
            End If
        End With
   '.Close
End With
 
        With WbkMaitre
            .Activate
            a = .Sheets("Commande").Range("c3").Resize(nbLign).Value
            lim = UBound(a)
        ReDim temp(1 To lim, 1 To 1)
            k = 1
            cpt = 0
                temp(1, 1) = a(1, 1)
        For i = 1 To lim
        For j = 1 To lim
    If a(i, 1) = temp(j, 1) Then Exit For
                cpt = cpt + 1
        Next j
    If cpt = lim Then k = k + 1: temp(k, 1) = a(i, 1)
     cpt = 0
        Next i
        For i = 1 To k
        Call Cde_Equip(WbkMaitre, .Sheets("Commande"), repertoire, temp(i, 1))
        Next i
    End With
    Call sauvegarde
    End Sub
 
Sub Cde_Equip(Maitre As Workbook, FeuilBase As Worksheet, ByVal rep As String, ByVal numEquip As Long)
Dim nbLign As Long, derLign&, i&, derLignA&, derLignC&
Dim trouve As Range, plageEquip As Range
FeuilBase.Copy before:=Maitre.Sheets(1)
With ActiveSheet
.Range("C3:Z45").Sort Key1:=.Range("C3"), Order1:=xlAscending, Key2:=.Range("D3") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
nbLign = Application.CountIf(.Range("C3:C45"), numEquip)
Set trouve = .Range("C2:C45").Find(numEquip, LookIn:=xlValues, LookAt:=xlWhole)
Set plageEquip = trouve.Resize(nbLign, 24)
Set ExistFichier = Nothing
On Error Resume Next
Set ExistFichier = Workbooks.Open(rep & "BD_equipe_1.xls", Updatelinks:=False)
On Error GoTo 0
If ExistFichier Is Nothing Then
MsgBox "L'équipe " & numEquip & " n'a pas de fichier." & vbCrLf & _
"Veuillez en créer un.", vbExclamation
Exit Sub
End If
 
Sheets("Data").Select
plageEquip.Copy
derLign = IIf(Range("C" & Rows.Count).End(xlUp).Row + 1 < 3, 3, Range("C" & Rows.Count).End(xlUp).Row + 1)
With Cells(derLign, 3)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
'suppression des doublons
Columns(3).Insert xlToRight
For Each cel In Range("D" & derLign).Resize(nbLign)
doublon = Evaluate("SumProduct((" & Range("D3:D" & derLign - 1).Address & "=" & cel.Value & ")*(" & Range("E3:E" & derLign - 1).Address & "=" & cel.Offset(, 1).Value & "))")
If doublon > 0 Then Cells(cel.Row, 3).Value = "$$$"
Next cel
Set trouve = Range("C" & derLign).Resize(nbLign).Find("$$$", LookAt:=xlWhole)
If Not trouve Is Nothing Then
For i = nbLign + derLign - 1 To derLign Step -1
If Cells(i, 3) = "$$$" Then Rows(i).Delete
Next i
End If
Columns(3).Delete
derLignC = Range("C" & Rows.Count).End(xlUp).Row
derLignA = IIf(Range("A" & Rows.Count).End(xlUp).Row + 1 < 3, 3, Range("A" & Rows.Count).End(xlUp).Row + 1)
If derLignC > derLignA Then
For i = derLignA To derLignC
Cells(i, 1) = Cells(i - 1, 1) + 1
Next i
End If
Application.DisplayAlerts = False
.Delete
End With
End Sub
 
Sub sauvegarde()
Dim i
Application.ScreenUpdating = False
For i = Workbooks.Count To 1 Step -1
If Left(Workbooks(i).Name, 3) = "BD_" Then
With Workbooks(i)
    .Activate
   .RefreshAll
   .Close Savechanges:=True
End With
End If
Next
End Sub

L'aide pour rajouter le code VBA [XL-MAC 2011]

Macros et VBA Excel

Discussions similaires

Partager

Partager