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
| Option Explicit
Sub misterW()
Dim oTabl() As String
Dim oDim As Integer
Dim oBool As Boolean
Dim oRng As Range, oCell As Range
Dim i As Integer, j As Integer
Dim oFin As Range
Dim Val As Single
With Worksheets("Feuil4")
oDim = 1
ReDim oTabl(1 To oDim)
Set oRng = .Range("A1")
For i = 1 To .Columns(1).Find("*", , , , , xlPrevious).Row - 1
oBool = True
For j = LBound(oTabl) To UBound(oTabl)
If oRng.Offset(i, 0) = oTabl(j) Then
oBool = False
End If
Next j
If oBool Then
ReDim Preserve oTabl(1 To oDim)
oTabl(oDim) = oRng.Offset(i, 0)
oDim = oDim + 1
End If
Next i
Set oFin = Worksheets("Feuil5").Range("A1")
For j = LBound(oTabl) To UBound(oTabl)
Val = 0
Set oRng = FindAll(oTabl(j), .Columns(1), xlFormulas, xlWhole)
For Each oCell In oRng
Val = Val + oCell.Offset(0, 1) * oCell.Offset(0, 2)
Next oCell
With Worksheets("Feuil5")
oFin.Offset(j, 0) = oTabl(j)
oFin.Offset(j, 1) = Val
End With
Next j
End With
End Sub
Function FindAll(What, Optional SearchWhat As Variant, _
Optional LookIn, _
Optional LookAt, _
Optional SearchOrder, _
Optional SearchDirection As XlSearchDirection = xlNext, _
Optional MatchCase As Boolean = False, _
Optional MatchByte, _
Optional SearchFormat) As Range
'LookIn can be xlValues or xlFormulas, _
LookAt can be xlWhole or xlPart, _
SearchOrder can be xlByRows or xlByColumns, _
SearchDirection can be xlNext, xlPrevious, _
MatchCase, MatchByte, and SearchFormat can be True or False. _
Before using SearchFormat = True, specify the appropriate settings _
for the Application.FindFormat object, e.g., _
Application.FindFormat.NumberFormat = "General;-General;""-"""
Dim aRng As Range
If IsMissing(SearchWhat) Then
On Error Resume Next
Set aRng = ActiveSheet.UsedRange
On Error GoTo 0
ElseIf TypeOf SearchWhat Is Range Then
If SearchWhat.Cells.Count = 1 Then
Set aRng = SearchWhat.Parent.UsedRange
Else
Set aRng = SearchWhat
End If
ElseIf TypeOf SearchWhat Is Worksheet Then
Set aRng = SearchWhat.UsedRange
Else
Exit Function '*****
End If
If aRng Is Nothing Then Exit Function '*****
Dim FirstCell As Range, CurrCell As Range
With aRng.Areas(aRng.Areas.Count)
Set FirstCell = .Cells(.Cells.Count)
'This little 'dance' ensures we get the first matching _
cell in the range first
End With
Set FirstCell = aRng.Find(What:=What, After:=FirstCell, _
LookIn:=LookIn, LookAt:=LookAt, _
SearchDirection:=SearchDirection, MatchCase:=MatchCase, _
MatchByte:=MatchByte, SearchFormat:=SearchFormat)
If FirstCell Is Nothing Then Exit Function '*****
Set CurrCell = FirstCell
Set FindAll = CurrCell
Do
Set FindAll = Application.Union(FindAll, CurrCell)
'Setting FindAll at the top of the loop ensures _
the result is arranged in the same sequence as _
the matching cells; the duplicate assignment of _
the first matching cell to FindAll being a small _
price to pay for the ordered result
Set CurrCell = aRng.Find(What:=What, After:=CurrCell, _
LookIn:=LookIn, LookAt:=LookAt, _
SearchDirection:=SearchDirection, MatchCase:=MatchCase, _
MatchByte:=MatchByte, SearchFormat:=SearchFormat)
'FindNext is not reliable because it ignores the FindFormat settings
Loop Until CurrCell.Address = FirstCell.Address
End Function |
VBA calculer prix d'un éléments à plusieurs valeurs
Répondre avec citation
les réponses pertinentes et n'oublier pas de résolver 
en fin de post ! 
Partager