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 |
