Option Explicit
Sub NbOccurence()
' Code OK
Dim Matches As Object
Dim Match As Object
Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")
Dim chaine() As Variant
Dim i As Integer, col As Integer, Box As Integer, j As Integer, k As Integer
chaine = Range(Cells(3, 4), Cells(Cells(65535, 5).End(xlUp).Row, 5)) '
ReDim Preserve chaine(LBound(chaine, 1) To UBound(chaine, 1), LBound(chaine, 2) To 11)
For i = LBound(chaine, 1) To UBound(chaine, 1)
' chaine(i, 3) = "((^" & chaine(i, 2) & "[.,;?!]){1,}|" _
' & "(^" & chaine(i, 2) & "\s){1,}|" _
' & "(\b" & chaine(i, 2) & "\b){1,}|" _
' & "(" & chaine(i, 2) & "[.,;?!]\s){1,}|" _
' & "(" & chaine(i, 2) & "\s){1,}|" _
' & "(\s" & chaine(i, 2) & "[.,;?!]\s){1,}|" _
' & "(\s" & chaine(i, 2) & "\s){1,}|" _
' & "(\s" & chaine(i, 2) & "[.,;?!]){1,}|" _
' & "(\s" & chaine(i, 2) & "){1,}|" _
' & "(\s" & chaine(i, 2) & "[.,;?!]$)|" _
' & "(\s" & chaine(i, 2) & "$))"
chaine(i, 3) = "((^" & chaine(i, 2) & "[.,;?!]){1,}|" _
& "(^" & chaine(i, 2) & "\s){1,}|" _
& "(\b" & chaine(i, 2) & "\b){1,}|" _
& "(\b" & chaine(i, 2) & "[.,;?!]\s){1,}|" _
& "(\b" & chaine(i, 2) & "\s){1,}|" _
& "(\s" & chaine(i, 2) & "[.,;?!]\s){1,}|" _
& "(\s" & chaine(i, 2) & "\s){1,}|" _
& "(\s" & chaine(i, 2) & "[.,;?!]){1,}|" _
& "(\s" & chaine(i, 2) & "\b){1,}|" _
& "(\s" & chaine(i, 2) & "[.,;?!]$)|" _
& "(\s" & chaine(i, 2) & "$))"
' chaine(i, 3) = "(\b" & chaine(i, 2) & "\b)"
Next i
' Recherche en colonne :
For i = LBound(chaine, 1) To UBound(chaine, 1)
For j = LBound(chaine, 1) To UBound(chaine, 1)
reg.Pattern = chaine(i, 3)
reg.MultiLine = True: reg.IgnoreCase = False: reg.Global = True
Debug.Print reg.test(chaine(j, 1))
Set Matches = reg.Execute(chaine(j, 1))
For k = 0 To Matches.Count - 1
'MsgBox UCase(Mid(chaine(j, 1), Matches(k).FirstIndex + 1, 1))
'MsgBox UCase(Mid(chaine(j, 1), (Matches(k).FirstIndex + 1 + Matches(k).Length), 1))
chaine(i, 4) = chaine(i, 4) + Matches.Item(k)
Next k
Next j
Next i
' Recherche doubon dans la chaine
For i = LBound(chaine, 1) To UBound(chaine, 1)
DoublonChaine chaine, i, 4, 5
Next i
' Recherche en Ligne :
For i = LBound(chaine, 1) To UBound(chaine, 1)
reg.Pattern = chaine(i, 3)
reg.MultiLine = True: reg.IgnoreCase = False: reg.Global = True
Debug.Print reg.test(chaine(i, 1))
Set Matches = reg.Execute(chaine(i, 1))
If reg.test(chaine(i, 1)) = True Then
chaine(i, 6) = "OUI"
'DoublonChaine chaine, i, 1, 7
chaine(i, 6) = Matches.Count
Else
chaine(i, 6) = "NON"
chaine(i, 7) = 0
End If
chaine(i, 11) = chaine(i, 7) * Len(chaine(i, 2))
For Each Match In Matches
If (Match.Length + Match.FirstIndex) < (Len(chaine(i, 1)) / 3) Or Match.FirstIndex = 0 Then
chaine(i, 8) = "X"
ElseIf (Match.Length + Match.FirstIndex) > (Len(chaine(i, 1)) / 3) * 2 Or (Match.Length + Match.FirstIndex) = Len(chaine(i, 1)) Then
chaine(i, 10) = "X"
Else
chaine(i, 9) = "X"
End If
Next
Next i
' libération d'objets
Set Matches = Nothing
Set Match = Nothing
Set reg = Nothing
'For i = 5 To 11
' Cells(3, i + 1).Resize(UBound(chaine, 1)) = Application.Index(chaine, , i)
'Next i
For i = LBound(chaine, 1) To UBound(chaine, 1)
For j = 5 To UBound(chaine, 2)
Cells(i + 2, j + 1) = chaine(i, j)
Next j
Next i
End Sub
Sub DoublonChaine(chaine() As Variant, i As Integer, col As Integer, Box As Integer)
Dim n As Integer, Rech As Integer, j As Integer
n = Len(chaine(i, 2)) ' nombre de caractères à rechercher (n = x -> on recherche la répétition de deux caractères)
Rech = Len(chaine(i, col)) ' Longueur total de la chaine
For j = 1 To Rech
If UCase(chaine(i, 2)) = UCase(Mid(chaine(i, col), j, n)) Then
chaine(i, Box) = chaine(i, Box) + 1
End If
Next j
End Sub
