Regrouper les caractères identiques d'une chaine de caractère variable

Coucou tout le monde!

Je sollicite à nouveau votre aide pour une petite macro que j'aimerai mettre en place. Mon objectif étant de créer une référence produit avec 3 chaine de caractère différente.

Ma référence est constitué ainsi:

VTUG-18-MSD-S1TZ-25V20-G38-DT-G14S- [Chaine de caractère fixe]
AAAAVKVKVKTSLLLLLAA [Chaine de caractère variable]
+M2 [Chaine de caractère optionnelle]

Le but étant de créer une Function qui permettrais de récupérer la [Chaine de caractère variable], qui est saisie par l'utilisateur dans une "Zone de texte" UserForm, et de regrouper les caractères identiques afin de donner ceci: 4A3VKTS5LAA

Un fois faite, je l'intégrerais à mon Sub (déjà réalisé) pour constituer une référence produit comme suite:

VTUG-18-MSD-S1TZ-25V20-G38-DT-G14S-4A3VKTS5LAA +M2

/!\ Attention

Les caractères utilisés seront uniquement A, VK, TS et L.
La Function dois regroupé les caractères identiques se répétant 3x ou plus. (ne pas regrouper les caractères identiques consécutifs <=2)
La [Chaine de caractère variable] ne contiendra que des caractère saisies aléatoirement (exemple: AAAALLLLVK; VKVKVKVKLLLATS; AAVKL; etc...)

Pour ceux qui ont une idée, je prend!
Merci par avance pour votre temps.

Bonjour,

une solution via une fonction personnalisée

Function cch(sTexte As String) As String
'Les caractères utilises seront uniquement A, VK, TS et L.
'La Function doit regrouper les caractères identiques se repetant 3x ou plus. (ne pas regrouper les caractères identiques consecutifs <=2)
'La [Chaine de caractère variable] ne contiendra que des caractères saisis aleatoirement (exemple: AAAALLLLVK; VKVKVKVKLLLATS; AAVKL; etc...)

Dim sChaine_Modifiee As String, sChaine_Resultat As String, sCaractere As String, sCaractere_Precedent As String
Dim lgCompteur_Caracteres As Long, lgPosition_Caractere As Long

    sChaine_Modifiee = Replace(sTexte, "VK", "@")
    sChaine_Modifiee = Replace(sChaine_Modifiee, "TS", "§") & " "
    sChaine_Resultat = ""
    lgCompteur_Caracteres = 0
    sCaractere_Precedent = ""

    For lgPosition_Caractere = 1 To Len(sChaine_Modifiee)
        sCaractere = Mid(sChaine_Modifiee, lgPosition_Caractere, 1)
            If sCaractere = sCaractere_Precedent Then
                lgCompteur_Caracteres = lgCompteur_Caracteres + 1
            Else
                If lgCompteur_Caracteres > 0 Then
                    If lgCompteur_Caracteres <= 2 Then
                        sChaine_Resultat = sChaine_Resultat & String(lgCompteur_Caracteres, sCaractere_Precedent)
                    Else
                        sChaine_Resultat = sChaine_Resultat & lgCompteur_Caracteres & sCaractere_Precedent
                    End If
                End If
                lgCompteur_Caracteres = 1
            End If
        sCaractere_Precedent = sCaractere
    Next lgPosition_Caractere

    sChaine_Resultat = Replace(sChaine_Resultat, "@", "VK")
    sChaine_Resultat = Replace(sChaine_Resultat, "§", "TS")
    cch = sChaine_Resultat

End Function

Wahou!!! Cette Function fonctionne très bien, h2so4!

Je te remercie.

Salut Renenkyo,
Salut H2so4,

difficile de faire mieux, évidemment, étant parti dans la même direction.
Merci, H2so4, de m'avoir fait découvrir la fonction STRING... et sa limitation étonnante à la copie d'1 seul caractère !!

Un clic dans la feuille ouvre l'USF.

Private Sub Transform(ByVal sTxt$)
'
Dim iNb%, sStr$, sData$, sProv$
'
If sTxt <> "" Then
    sTxt = sTxt & " "
    sProv = Left(sTxt, 1)
    For x = 1 To Len(sTxt)
        If Mid(sTxt, x, 1) <> sProv Then
            sStr = IIf(Asc(sProv) < 80, sProv, IIf(sProv = "V", "VK", "TS"))
            sData = sData & IIf(iNb < 3, IIf(iNb = 1, sStr, sStr & sStr), Trim(Str(iNb)) & sStr)
            sProv = Mid(sTxt, x, 1)
            iNb = 0
        End If
        iNb = iNb + 1
        x = x + IIf(Asc(sProv) < 80, 0, 1)
    Next
End If
Me.lbl1.Caption = sData
'
End Sub

A+