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 110 111 112 113 114 115 116 117 118
| Option Explicit
Dim flag As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim data1 As String, val1 As String
Dim cellule As Range
Dim dl1 As Long ' dernière ligne
Dim i As Integer
Dim numerique As Boolean, trouve As Boolean
Dim frontdescend As Boolean, avantnumerique As Boolean, frontmontant As Boolean
Dim tabl() As Variant, val2 As Variant
Dim nbc() As Byte, j As Byte, i1 As Byte
If flag = True Then Exit Sub
If Target.Count > 1 Then Exit Sub
i = (Target.Row + 1) Mod 4 ' à supprimer si le résultats en colonne
If i <> 0 Then Exit Sub ' à supprimer si le résultats en colonne
If Target = "" Then Exit Sub
With Sheets(Target.Worksheet.Name)
dl1 = .Range("a65536").End(xlUp).Row ' à supprimer
If Not Intersect(Target, Range("a1:a" & dl1)) Is Nothing Then ' a supprimer et remplacer par la ligne suivante
'If Not Intersect(Target, Range("a2:a" & 2)) Is Nothing Then
flag = True
.Range("B" & Target.Row & ":CA" & Target.Row + 2).ClearContents 'a supprimer et remplacer par la ligne suivante
'.Range("B2:C1000").ClearContents
val1 = CStr(Target.Value) & "£"
For i = 1 To Len(val1)
' on recherche la première position
If IsNumeric(Mid(val1, i, 1)) Or Mid(val1, i, 1) = "," Then
numerique = True
Else
numerique = False
End If
If numerique = True And avantnumerique = False Then
frontmontant = True
Else
frontmontant = False
End If
avantnumerique = numerique
If frontmontant = True Then i1 = i1 + 1
Next i
Target.Offset(0, 1) = i1
ReDim tabl(1 To i1)
ReDim nbc(1 To i1)
j = 1
For i = 1 To Len(val1)
' on recherche la première position
If IsNumeric(Mid(val1, i, 1)) Or Mid(val1, i, 1) = "," Then
numerique = True
Else
numerique = False
End If
If numerique = False And avantnumerique = True Then
frontdescend = True ' apparition d'une valeur
Else
frontdescend = False
End If
avantnumerique = numerique
If numerique Then val2 = val2 & Mid(val1, i, 1)
If frontdescend = True Then ' le nombre est fini
If j > 1 Then
trouve = False
For i1 = LBound(tabl()) To j
If tabl(i1) = val2 Then
nbc(i1) = nbc(i1) + 1
trouve = True
Exit For
End If
Next i1
If trouve = False Then
tabl(j) = val2
nbc(j) = 1
j = j + 1
End If
Else
tabl(j) = val2
nbc(j) = 1
j = j + 1
End If
val2 = ""
End If
Next i
For i = 1 To j
If nbc(i) > 0 Then
Target.Offset(0, i + 1).Value = Replace(tabl(i), ",", ".")
Target.Offset(1, i + 1).Value = nbc(i)
Target.Offset(2, i + 1) = tabl(i) * nbc(i)
' si colonnes au lieu de lignes supprimer les 3 lignes ci dessus
'Target.Offset(i+1,1).Value = Replace(tabl(i), ",", ".")
'Target.Offset(i+1, 2).Value = nbc(i)
'Target.Offset(i+1, 3) = tabl(i) * nbc(i)
End If
Next i
End If
End With
flag = False
End Sub |