[Résolu] Savoir si un nom est masculin ou féminin

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Target.Address <> "$B$4" And Target = "" Then Exit Sub
With Sheets(2).Range("b2:b101")
    Set c = .Find(Target)
    If Not c Is Nothing Then
        Select Case c.Offset(0, -1)
            Case "féminin"
            Target = "une " & Target
            Case "masculin"
            Target = "un " & Target
        End Select
    End If
End With
End Sub

Private Sub Worksheet_Change(ByVal c As Range)
Dim commun As String

If Intersect(c, Range("b4")) Is Nothing Then Exit Sub

   commun = Range("b4").Value
   
   If NOM_COMMUN(commun) <> "" Then
     Range("b2").Value = "Nom masculin"
  Else
     Range("b2").Value = "Nom féminin"
  End If
  
With Range("b2")
.Font.Size = 13
.Font.FontStyle = "Bold Italic"
.HorizontalAlignment = xlCenter
End With

If Range("b4") = "" Then Range("b2").ClearContents
End Sub

Private Sub Worksheet_SelectionChange(ByVal c As Range)
Application.Goto Range("b4")
End Sub

Private Function NOM_COMMUN(plage As String) As String
     If Int((2 * Rnd) + 1) > 1 Then Exit Function
      NOM_COMMUN = Range("b4").Value
End Function

Private Sub Worksheet_Change(ByVal C As Range)
    Dim R As Range, Nom$, Genre$
    If C.Address <> "$B$4" Then Exit Sub
    Application.EnableEvents = False
    Nom = Right(C, Len(C) - InStrRev(C, " ")): Genre = Left(C, InStrRev(C, " "))
    Set R = Feuil2.Columns(2).Find(Nom)
    If Not R Is Nothing Then
        If R.Offset(, -1) = "un" Then
            If Genre <> "un " And Genre <> "le " Then
                [B2] = "mauvais genre": GoTo 1
            End If
        Else
            If Genre <> "une" And Genre <> "la " Then
                [B2] = "mauvais genre": GoTo 1
            End If
        End If
        With [B2]
            .Value = Nom & " est du genre " & IIf(R.Offset(, -1) = "un", "masculin", "féminin")
            .Font.Size = 13
            .Font.FontStyle = "Bold Italic"
            .HorizontalAlignment = xlCenter
        End With
    End If
1   Application.EnableEvents = True
    If [B4] = "" Then [B2].Clear
End Sub

Option Explicit
'Liste des articles : triée du plus long au plus court avec espace final
Const LesArticles = "de la /de l' /aux /des /des /les /une /au /du /la /le /un /d' /l' "
Const LesGenresArticles = "f/?/?/?/?/?/f/m/m/f/m/m/?/?"

Public Function GenreMot(Mot As String)

'  "f/m" ==> genre indéterminé (ex: la mousse ou le mousse)
'  "f"   ==> féminin       "m" ==> masculin
'  "(Art. saisi erroné)"  ==> erreur par rapport au genre saisi

Dim T_art, T_genre_art, xart, xmot, i
Dim GenreArticle, VraiGenre, xTrouve As Range

' mot vide
If Trim(Mot) = "" Then
   GenreMot = ""
   Exit Function
End If

' Initialisation
GenreMot = ""
T_art = Split(LesArticles, "/")
T_genre_art = Split(LesGenresArticles, "/")
xmot = LCase(Replace(Trim(Mot), "'", "' "))

'Boucle élimination article
For i = 0 To UBound(T_art)
   If xmot Like T_art(i) & "*" Then
      xmot = Trim(Mid(xmot, Len(T_art(i)) + 1))
      GenreArticle = T_genre_art(i)
      Exit For
   End If
Next i
If xmot = "" Then Exit Function

'chercher le mot
Set xTrouve = Sheets("Lexique3.80").Range("A1:A50000").Find(What:=xmot, _
   LookIn:=xlValues, LookAt:=xlWhole)

If xTrouve Is Nothing Then
   'Mot non trouvé => Erreur
   GenreMot = "mot inconnu"
   Exit Function
Else
   'le mot a été trouvé - vérif du genre trouvé et du genre saisi
   VraiGenre = xTrouve.Offset(, 1).Value
   Select Case GenreArticle
      Case ""           'l'utilisateur n'avait rentré aucun article
         GenreMot = IIf(VraiGenre = "", "f/m", VraiGenre)
      Case "f", "m"     'l'utilisateur avait rentré un article sexué
         If GenreArticle = VraiGenre Or VraiGenre = "" Then
            GenreMot = IIf(VraiGenre = "", "f/m", VraiGenre)
         Else
            GenreMot = VraiGenre & vbLf & " (Art. saisi erroné)"
         End If
      Case "?"          'l'utilisateur avait rentré un article assexué
         GenreMot = IIf(VraiGenre = "", "f/m", VraiGenre)
   End Select
End If
         
End Function

Set cel = .Find(Mid(c, InStr(1, c & " ", " ") + 1), , xlValues, xlPart)

Private Declare Function OuvreInternet Lib "wininet" _
     Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, _
     ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function fermeInternet Lib "wininet" _
     Alias "InternetCloseHandle" (ByVal hInet As Long) As Integer
Private Declare Function code_page Lib "wininet" _
     Alias "InternetReadFile" (ByVal hFile As Long, ByVal sBuffer As String, _
     ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function Ouvrepage Lib "wininet" _
     Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, _
     ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, _
     ByVal dwContext As Long) As Long

Sub lit_code_page_Web()
Dim texte_code As String * 1024
Dim t#, Mot$

Const L = "la ,le ,l',un ,une"
Const L2 = "&~#'{([-|`_\ç^@)]=}$¤£+°^¨*µ%!§:/;.,?<>0123456789"

Mot = LCase(Range("B4"))
'on isole le mot uniquement, sans son article
For t = LBound(Split(L, ",")) To UBound(Split(L, ","))
  Mot = Replace(Mot, Split(L, ",")(t), "")
Next t

'on vire les caractères parasites
For t = 1 To Len(L2)
  Mot = Replace(Mot, Mid(L2, t, 1), "")
Next t

'Recherche sur le web
page_Web_à_lire = "http://dictionnaire.reverso.net/francais-definition/" & Mot
internet = OuvreInternet("toto", 0, vbNullString, vbNullString, 0) 'ouvre Internet
URL = Ouvrepage(internet, page_Web_à_lire, vbNullString, _
    0, &H400000 Or &H4000000 Or &H80000000, 0) 'ouvre la page Web
'lecture du code de la page par paquet de 1024 caractères
txt = ""
nb_caractères_lus = 1
'Récupération du code source
Do While nb_caractères_lus > 0
'lit 1024 caractères et les copie dans texte_code
 code_page URL, texte_code, 1024, nb_caractères_lus
 txt = txt & Left(texte_code, nb_caractères_lus)
Loop
fermeInternet URL 'ferme la page
fermeInternet internet 'ferme Internet

'détermination du genre
genre = "Non déterminé"
If InStr(txt, ">nm") > 0 Then genre = "Nom Masculin"
If InStr(txt, ">nf") > 0 Then genre = "Nom féminin"

Range("C4") = genre
End Sub