XL 2019 Comment réaliser une saisie intuitive type (ab ab = Abies alba) et qui garde la mise en forme couleur de la BD sous userform

[lusert]

Bonjour cher réseau,

Je sollicite votre aide,
Je perfectionne depuis un certain temps une fiche de relevé sur la flore. J'ai commencé sur du private sub liée à une combobox directement sur la feuille de saisie en question. Le problème, c'est que hors plage de saisie (B22: B160) je ne pouvais faire de retour en arrière si faute de frappe ou suppression d'un mot. A ce code private sub j'avais de mémoire fusionner deux codes d'un certain boisgontierjacques pour bénéficier d'une saisie intuitive basée sur la recherche de caractère même après un espace (ex : pour avoir "abies alba" j'écris juste "ab ba") tout en y combinant un code gardant la mise en forme du texte de donnée (ex : dans ma BD j'ai abies alba et je retrouve le texte de même couleur sur ma feuille de saisie). En complément j'ai pu intégrer un code sub en private sub basé sur la mise en forme en italique selon des balises qui transforme une partie du texte en italique tout en supprimant la fin les symboles servant de limite aux balises (ex :

" <i>Abies alba sp. Dfdg dfgdfg </i>Eerr Mill., 1769 " devient "Abies alba sp. Dfdg dfgdfg Eerr Mill., 1769")

Voilà le travail que j'ai pu faire à l'aide de votre réseau.
Aujourd'hui je me suis lancé sous userform pour l'esthétisme et pouvoir revenir en arrière suite à une mauvaise saisie hors plage de donnée de la combobox.
Tout fonctionne, ainsi que l'adaptation du texte en italique en supprimant les deux symboles html par contre je ne vois pas comment adapter le code qui garde la mise en forme couleur texte et surlignage ni comment l'adater à une saisie type "ab ab 1769" ou ab ab donne "Abies alba sp. Dfdg dfgdfg </i>Eerr Mill., 1769 "

Merci d'avance pour vos éclairements

Thomas un naturaliste qui cherche à simplifier la retranscription de ses relevés après une dure et longue journée de terrain

 

[lusert]

Je m'aperçois que j'ai oublié les codes ^^ je vous les joins
Codes basées sur du private sub directement liée à la feuille de saisie (voir fichier saisie caractère par caractère) :
Ps: je ne suis pas sur que ce code soit bien écrit ? j'ai en trotte juste copié coller la partie liée au LBound(tmp) To UBound(tmp) au code lié à Ucase

Private Sub ComboBox1_Change()

  If Me.ComboBox1 <> "" And IsError(Application.Match(Me.ComboBox1, a, 0)) Then

    Set d1 = CreateObject("Scripting.Dictionary")

    tmp = UCase(Me.ComboBox1) & "*"

    For Each c In a

      If UCase(c) Like tmp Then d1(c) = ""

    Next c

    Me.ComboBox1.List = d1.keys

    Me.ComboBox1.DropDown

  End If

  ActiveCell.Value = Me.ComboBox1

    Dim Ind As Long, n As Long, Tt()

  ' Si le flag est actif on sort

  If FlgExit Then Exit Sub

  ' Vérifier si aucune valeur saisie

  If Me.ComboBox1 <> "" Then

     tmp = Split(Trim(Me.ComboBox1), " ")     ' divise puis réduit la combobox

     Tbl = a

     For i = LBound(tmp) To UBound(tmp)

       Tbl = Filter(Tbl, tmp(i), True, vbTextCompare)

     Next i

     Me.ComboBox1.List = Tbl

     Me.ComboBox1.DropDown

 End If


End Sub

 

[lusert]

Maintenant que l'on y voit plus clair voici le code private sub basée sur un userform au sein du quel j'essaie d'intégrer toute les composantes du premier fichier
voila à quoi ressemble ce début de code mais je n'arrive pas intégrer cette saisie basé sur par exemple "ab ab" pour avoir "Abies alba", ni à intégrer le code qui garde le texte ou son surlignage en couleur de la BD et dernière chose pourquoi dans la capture d'écran ci-dessous la combobox nom latin affiche en visuel deux colonne ? (je préférerais voir plutôt une colonne avec tout son texte.
le code ci-dessous

Private Sub Label1_Click()

End Sub

Private Sub Label3_Click()

End Sub

Private Sub Label4_Click()

End Sub

Private Sub UserForm_Initialize()
Dim f
Set f = Sheets("BD")
ComboBox1.Clear
i = 0
Set design = f.Range("A2:A" & f.[a65000].End(xlUp).Row)
For Each c In design
    If c <> "" Then tmp = c
    Me.ComboBox1.AddItem tmp
    Me.ComboBox1.List(i, 1) = c.Offset(, 1)
    Me.ComboBox1.List(i, 2) = c.Offset(, 2)
    Me.ComboBox1.List(i, 3) = c.Offset(, 3)
    Me.ComboBox1.List(i, 4) = c.Row
    i = i + 1
Next
End Sub
Private Sub ComboBox1_click()
  Me.TextBox1 = Me.ComboBox1.Column(1)
  Me.TextBox2 = Me.ComboBox1.Column(2)
  Me.TextBox3 = Me.ComboBox1.Column(3)
End Sub

Private Sub B_ok_Click()

  ActiveCell.Offset(, 0) = Me.TextBox3
  ActiveCell.Offset(, -1) = Me.TextBox2
  ActiveCell.Font.Name = "Arial"
  ActiveCell.Font.Size = 11 'Affiche toute la plage de cellule en taille de police 11
  ActiveCell.Font.Bold = False

ActiveCell.Interior.Color = RGB(226, 239, 218)
   Dim balise1$, balise2$, L1$, L2$, a$(), c As Range, n&, x$, sup%, i%, j%, k%, ss, s
balise1 = "<i>": balise2 = "</i>": L1 = Len(balise1): L2 = Len(balise2)
Application.ScreenUpdating = False
ActiveCell.Font.Italic = False 'RAZ
With ActiveSheet.UsedRange 'la feuille active est traitée
    '---tableau des bornes---
    ReDim a(1 To .Count)
    For Each c In .Cells
        n = n + 1
        x = CStr(c)
        sup = 0
        For i = 1 To Len(x)
            If Mid(x, i, L1) = balise1 Then
                j = InStr(i + L1, x, balise2)
                k = InStr(i + L1, x, balise1)
                If k = 0 Then k = 32767
                If j And j <= k Then
                    sup = sup + L1
                    a(n) = a(n) & " " & i - sup + L1 & "," & j - i - L1
                    sup = sup + L2
                    i = j + L2 - 1
                End If
            End If
    Next i, c
    '---effacement des 2 balises---
    .Replace balise1, "", xlPart
    .Replace balise2, ""
    '---application des formats---
    n = 0
    For Each c In .Cells
        n = n + 1
        If a(n) <> "" Then
            ss = Split(a(n))
            For i = 1 To UBound(ss)
                s = Split(ss(i), ",")
                c.Characters(s(0), s(1)).Font.Italic = True
            Next i
        End If
    Next c
End With
If Me.ComboBox1 <> "" Then 'Si la zone de saisie de la combobox comporte un de ces mots alors il sera sans italic
mot = "subsp."
  For Each c In Range("B22:B180")
   P = InStr(UCase(c), UCase(mot))
   If P > 0 Then c.Characters(Start:=P, Length:=Len(mot)).Font.Italic = False 'Valeur italique fausse, donc Subsp ecrit sans italic
  Next c
  mot2 = "var."
  For Each c In Range("B22:B180")
   P = InStr(UCase(c), UCase(mot2))
   If P > 0 Then c.Characters(Start:=P, Length:=Len(mot2)).Font.Italic = False
  Next c
  mot3 = "sp."
  For Each c In Range("B22:B180")
   P = InStr(UCase(c), UCase(mot3))
   If P > 0 Then c.Characters(Start:=P, Length:=Len(mot3)).Font.Italic = False
  Next c
  mot3 = "x"
  For Each c In Range("B22:B180")
   P = InStr(UCase(c), UCase(mot3))
   If P > 0 Then c.Characters(Start:=P, Length:=Len(mot3)).Font.Italic = False
  Next c
  End If
   



  Unload Me
End Sub

Hâte de voir votre magie opérée

Thomas

 

[lusert]

Après avoir cliquer sur tous les boutons imaginable de ma propriété userfom j'ai pu résoudre le soucis montré par la capture d'écran. IL fallait juste augmenter le nombre de caractère présent dans la combobox soit :
Columlwidths : 250 pt; 250 pt ; 0 pt ; 0pt; 0 pt ; 0pt
Bon par contre je n'ai aucune idée de ce que ça veut réellement dire (j'en ai fais mon interprétation )