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
| Sub test()
Dim R As Range
Dim L As Long
Dim i As Long
Dim Occurrence As Long
Dim trouve As Boolean
Set R = ActiveSheet.UsedRange
Occurrence = 0
For i = 2 To R.Rows.Count
L = 1
trouve = False
If Trim("" & R(i, 3)) <> "" Then
Do While L <> 0
L = SerchXls(ActiveSheet.Range("d:d"), ActiveSheet.Range("d" & L), R(i, 3), False)
If L > 0 Then
If trouve = False Then Occurrence = Occurrence + 1
trouve = True
R(i, 5) = CalculOccurence(Occurrence)
R(L, 6) = R(i, 5)
End If
Loop
End If
Next
MsgBox "Fin"
End Sub
Function CalculOccurence(Occurrence As Long) As String
Dim t As String
Dim C As Long
Dim ICH As Integer
t = Space(Occurrence)
For i = 0 To Occurrence - 1
t = AZ_AutoIncrement(t, Occurrence)
Next
CalculOccurence = Trim(t)
End Function
Function AZ_AutoIncrement(ByVal t, C As Long) As String
Dim a As String
a = t
If Mid(t, C, 1) = " " Then Mid(t, C, 1) = "A": AZ_AutoIncrement = t: Exit Function
If Mid(t, C, 1) = "Z" Then Mid(t, C, 1) = "A": AZ_AutoIncrement = AZ_AutoIncrement(t, C - 1): Exit Function
Mid(t, C, 1) = Chr(Asc(Mid(t, C, 1)) + 1)
AZ_AutoIncrement = t
End Function
Function SerchXls(MyRange As Range, MyCellule As Range, strRecherche, EntierCell As Boolean) As Long '
On Error Resume Next
SerchXls = 0
Dim myxLookAt As Integer
If EntierCell = True Then myxLookAt = xlWhole Else myxLookAt = xlPart
SerchXls = MyRange.Cells.Find(What:=strRecherche, After:=MyCellule, LookIn:=xlFormulas, LookAt _
:=myxLookAt, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False).Row
If SerchXls <= MyCellule.Row Then SerchXls = 0
End Function |
Partager