Hi,

I modified the code now work correctly
Now it is full of all my requests
I hope both index
We accept tips

Code:
Option Explicit
Option Compare Text

Sub Maiuscole_Iniziali_VB6()
  Dim Ar, t, CicloA As Long
  Dim tx, ty, j, k, Testo As String
  Ar = [B3:B12]
  Dim CodesToSplit As Variant, X, s, Txt, H
  Dim CodesToReplace As String
  CodesToSplit = Array(".", "/")
  CodesToReplace = "di_da_con_per_mm_in_a_e"
  For CicloA = 1 To UBound(Ar)
    s = Ar(CicloA, 1)
    s = Split(s, " ")
    H = ""
    For Each t In s
      If Len(GetDigits(t & 0)) = 1 Then
        H = H & StrConv(t, vbProperCase) & " "
      Else
        H = H & UCase(t) & " "
      End If
    Next
    s = H
    
    H = ""
    For X = LBound(CodesToSplit) To UBound(CodesToSplit)
      If InStr(s, CodesToSplit(X)) Then
        Txt = Split(s, CodesToSplit(X))
        H = ""
        For Each t In Txt
          H = H & StrConv(t, vbProperCase) & CodesToSplit(X)
        Next
        H = Left(H, Len(H) - 1)
      End If
    Next
    If H = "" Then H = s
    Txt = Split(CodesToReplace, "_")
    For Each s In Txt
      H = Replace(H, " " & s & " ", " " & LCase(s) & " ")
    Next
    MsgBox H
  Next
End Sub

'http://www.excelfox.com/forum/f2/extract-numeric-value-from-alphanumeric-text-using-vba-regexp-853/

Function GetDigits(strAlNum As String) As Variant
  Dim X As Long
  For X = 1 To Len(strAlNum)
    If Mid(strAlNum, X, 1) Like "#" Then GetDigits = GetDigits & Mid(strAlNum, X, 1)
  Next
End Function