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
| Sub Creation_Listes()
Dim i As Long, DerLig As Long, B
Dim C As Range
Application.ScreenUpdating = False
Range("O1:S10000").ClearContents
For i = 2 To 6
Set B = CreateObject("Scripting.Dictionary")
For Each C In Range(Cells(5, i), Cells(Cells(10000, i).End(xlUp).Row, i))
If Not B.exists(C.Text) And C.Text <> "" Then B(C.Text) = ""
Next C
If B.Count > 0 Then Cells(1, i + 13).Resize(B.Count) = Application.Transpose(B.keys)
Range(Cells(1, i + 13), Cells(B.Count, i + 13)).Select
ActiveWorkbook.Names.Add Name:="Liste" & i, RefersToR1C1:="=Feuil1!R1C" & i + 13 & ":R" & B.Count & "C" & i + 13
Cells(2, i).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & "Liste" & i
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Next i
'Formules "Total"
DerLig = [B10000].End(xlUp).Row
Range("G2:K2").FormulaR1C1 = "=SUMPRODUCT((R5C2:R" & DerLig & "C2=R2C2)*(R5C3:R" & DerLig & "C3=R2C3)*(R5C4:R" & DerLig & "C4=R2C4)*(R5C5:R" & DerLig & "C5=R2C5)*(R5C6:R" & DerLig & "C6=R2C6),(R5C:R" & DerLig & "C))"
Set B = Nothing
End Sub |
Partager