'***************************************************************
' fonction de SUBSTITUEX (homolgue la fonction native "SUBSTITUE"
' auteur :patricktoulon
' date 08/06/2021
' version 1.0
' commentaires:
' Cette fonction sert a substituer un/des (caractères/ partie de chain) par un/des (caractères /partie de chaine) ou un mélange
' elle a pour vocation de diminuer le script des formules imbuvable quand trop de substitue
' quand elle est plusieurs fois utilisée dans une formule
'
' mise ajour
' version 1.2
' date 19/02/2022
' renommage des arguments(plus explicites)
' les arguments peuvent maintenant etre aussi des Ranges (1 ligne/x colonnes) ou (x lignes / 1 colonne)
' adjonction de la fonction (( GetdimensionTypeArray ))
' cette fonction me permet de déterminer (si /et) comment je ramène les arguments a un simple array 1 dim
' ajout de la macro description
'*************************************************************
Option Explicit
Function SUBSTITUEX(T As String, ByVal elements_a_remplacer As Variant, Optional ByVal elements_de_remplacement As Variant = "")
Dim I&, Q$
'conversion en variable tableau si Typerange
elements_a_remplacer = elements_a_remplacer
elements_de_remplacement = elements_de_remplacement
'conversion en array 1 dimension selon le type d'array injecté
Select Case GetdimensionTypeArray(elements_a_remplacer)
Case "vertical": elements_a_remplacer = Application.Transpose(elements_a_remplacer):
Case "ligne": elements_a_remplacer = Application.Index(elements_a_remplacer, 1, 0)
End Select
Select Case GetdimensionTypeArray(elements_de_remplacement)
Case "vertical": elements_de_remplacement = Application.Transpose(elements_de_remplacement)
Case "ligne": elements_de_remplacement = Application.Index(elements_de_remplacement, 1, 0)
End Select
For I = LBound(elements_a_remplacer) To UBound(elements_a_remplacer)
If IsArray(elements_de_remplacement) Then
If UBound(elements_de_remplacement) <> UBound(elements_de_remplacement) Then SUBSTITUEX = "notEqualBoundary": Exit Function
Q = elements_de_remplacement(I)
Else: Q = elements_de_remplacement
End If
T = Replace(T, elements_a_remplacer(I), Q)
Next
SUBSTITUEX = T
End Function
Function GetdimensionTypeArray(T)
'Fonction pour determiner le type de dimensionnement de la variable injectée(T)
'patricktoulon
Dim Tx, x&, Z, x2, z2&
z2 = UBound(T): If z2 = 0 Then x2 = Z + 1: x = x2 Else x = Z: x2 = x
Z = Switch(z2 = 1, "ligne", TypeName(Application.Index(T, z2, 2)) <> "Error", "tableau", x = x2, "vertical", x < x2 Or x > 1, "array")
If Z = "vertical" And TypeName(Application.Index(T, z2, 1)) = "Error" Then Z = "array"
GetdimensionTypeArray = Z
End Function
Sub UnregisterOptions()
On Error Resume Next
Application.MacroOptions Macro:="SUBSTITUEX", Description:=Empty, ArgumentDescriptions:=Empty, Category:=Empty
On Error GoTo 0
End Sub
Sub registerOptions()
Dim Funct_description As String, argumtsArray
'(max 255 caracteres)
Funct_description = "Fonction SUBSTITUEX" & vbCrLf & _
"Cette fonction sert a substituer" & vbCrLf & _
"Array;une chaine/carateres" & vbCrLf & " par" & vbCrLf & _
"Array;une chaine/carateres ou un melange" & vbCrLf & _
"Creted by patricktoulon"
'Description des arguments de la fonction
argumtsArray = Array("string:chaine à traiter", _
"array de chaine ou de carateres à substituer ((peut etre une Range))", _
"array de chaine ou de caratères de remplacecement ((peut etre une Range))")
'appel la sub pour enregistrer
Application.MacroOptions Macro:="SUBSTITUEX", _
Description:=Mid(Funct_description, 1, 255), _
ArgumentDescriptions:=argumtsArray, _
Category:="personnalisée"
End Sub