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
| Private Sub SansDoublonsTrie()
Dim MonDico As Object
Dim c As Range
'pour les essences
Set MonDico = CreateObject("Scripting.Dictionary")
With Worksheets("lotissement")
For Each c In .Range("A12:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
If Not MonDico.exists(Trim(c.Value)) Then MonDico.Add Trim(c.Value), Trim(c.Value)
Next c
With .Range("AE3").Resize(MonDico.Count, 1)
.Value = Application.Transpose(MonDico.keys)
.Sort Key1:=Worksheets("lotissement").Range("AE3"), Order1:=xlAscending, Header:=xlNo
End With
End With
Set MonDico = Nothing
' Calcul du volume selon essence et qualite
Dim i As Long, LigFin As Long
Dim fct As String, fct1 As String, fct2 As String, fct3 As String, fct4 As String
LigFin = [AE65536].End(xlUp).Row
For i = 3 To LigFin
fct = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AF$2))"
fct1 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AG$2))"
fct2 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AH$2))"
fct3 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AI$2))"
fct4 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AJ$2))"
Cells(i, 32) = Evaluate(fct)
Cells(i, 33) = Evaluate(fct1)
Cells(i, 34) = Evaluate(fct2)
Cells(i, 35) = Evaluate(fct3)
Cells(i, 36) = Evaluate(fct4)
Range("AK" & i) = Application.WorksheetFunction.Sum(Range("AF" & i), Range("AG" & i), Range("AH" & i), Range("AI" & i), Range("AJ" & i))
Next i
Call tri_qualite
End Sub
Private Sub Propriétaire()
Dim Dico As Object
Dim j As Range
Dim d As Variant
Dim b As Long
'tri sur les proprietaire sans doublons par ordre alpha
Set Dico = CreateObject("Scripting.Dictionary")
With Worksheets("lotissement")
For Each j In .Range("N12:N" & .Cells(.Rows.Count, 1).End(xlUp).Row)
If Not Dico.exists(Trim(j.Value)) Then Dico.Add Trim(j.Value), Trim(j.Value)
Next j
temp = Dico.items
Call Tri(temp, LBound(temp), UBound(temp)) ' voir module mod_tri
b = 3
For Each d In temp
.Cells(4, b) = d 'pour recopier la liste des éléments uniques à partir de la cellule C4
b = b + 1
Next d
.Cells(3, 21).Value = Application.WorksheetFunction.Proper(Join(temp, "-")) 'pour regrouper les apporteurs en cellules U3
End With
Set Dico = Nothing
End Sub
Sub Tri(j, gauc, droi) ' Quick sort
ref = j((gauc + droi) \ 2)
G = gauc: d = droi
Do
Do While j(G) < ref: G = G + 1: Loop
Do While ref < j(d): d = d - 1: Loop
If G <= d Then
temp = j(G): j(G) = j(d): j(d) = temp
G = G + 1: d = d - 1
End If
Loop While G <= d
If G < droi Then Call Tri(j, G, droi)
If gauc < d Then Call Tri(j, gauc, d)
End Sub |
Partager