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
| Sub DispatchFeuilles()
'References : Microsoft Scripting Runtime object library
Dim xlWbk As Workbook
Dim xlWsh As Worksheet, xlWshGlob As Worksheet
Dim rngGlob As Range, rngFM As Range, rngFiltre As Range, c As Range, rngTri As Range
Dim dicObj As Object
Dim i As Long, lastRowGlob As Long, lastColGlob As Long, lastRow As Long, lastCol As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set xlWbk = ThisWorkbook
Set xlWshGlob = xlWbk.Worksheets("GLOBAL")
For Each xlWsh In Worksheets
If xlWsh.Name <> "GLOBAL" Then
lastRow = xlWsh.Cells(xlWsh.Rows.Count, 1).End(xlUp).Row
lastCol = xlWsh.Cells(2, xlWsh.Columns.Count).End(xlToLeft).Column
xlWsh.Range(xlWsh.Cells(3, 1), xlWsh.Cells(lastRow, lastCol)).Clear
End If
Next xlWsh
With xlWshGlob
lastRowGlob = .Cells(.Rows.Count, 1).End(xlUp).Row
lastColGlob = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set rngGlob = .Range(.Cells(2, 1), .Cells(lastRowGlob, lastColGlob))
End With
With rngGlob
i = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Row
End With
With rngGlob
Set dicObj = CreateObject("Scripting.Dictionary")
Set rngFM = Range(Cells(2, 7).Offset(1), Cells(lastRowGlob, 7))
For Each c In rngFM
If dicObj.exists(c.Value) Then
Else
dicObj.Add c.Value, 0
.AutoFilter
.AutoFilter Field:=7, Criteria1:=c.Value
If i > 0 Then
Set rngFiltre = Range(Cells(i, 1), Cells(lastRowGlob, lastColGlob)).SpecialCells(xlCellTypeVisible)
For Each xlWsh In Worksheets
If xlWsh.Name = "FM" & c.Value Then
lastRow = Worksheets("FM" & c.Value).Range("A" & Rows.Count).End(xlUp).Row + 1
rngFiltre.Copy Destination:=Worksheets("FM" & c.Value).Range("A" & lastRow)
End If
If xlWsh.Name <> "FM" & c.Value And xlWsh.Name <> "GLOBAL" And xlWsh.Name = c.Value Then
lastRow = Worksheets(c.Value).Range("A" & Rows.Count).End(xlUp).Row + 1
rngFiltre.Copy Destination:=Worksheets(c.Value).Range("A" & lastRow)
End If
Next xlWsh
Else
MsgBox "Pas de ligne filtrée !", , "Aucune ligne trouvée"
Exit Sub
End If
End If
Next c
End With
xlWshGlob.AutoFilterMode = False
For Each xlWsh In Worksheets
If xlWsh.Name <> "GLOBAL" Then
lastRow = xlWsh.Cells(xlWsh.Rows.Count, 1).End(xlUp).Row
lastCol = xlWsh.Cells(2, xlWsh.Columns.Count).End(xlToLeft).Column
Set rngTri = xlWsh.Range(xlWsh.Cells(2, 1), xlWsh.Cells(lastRow, lastCol))
With xlWsh.Sort
.SortFields.Clear
.SortFields.Add Key:=xlWsh.Range("I2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=xlWsh.Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=xlWsh.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rngTri
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
xlWsh.Activate
xlWsh.Range("A2").Select
End If
Next xlWsh
xlWbk.Worksheets("GLOBAL").Activate
With Application
.CutCopyMode = False
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub |
