Clear text of specific characters in a celll with VBA-CodePudding

I'm looking for some help please with some VBA.

I have the next table

header1
000Model Test0Model Val00User0
Perman000User0Model Name000000
000Perman00000000000000000000Name

So I need to replace all Ceros with only one "," like this

header1
,Model Test,Model Val,User,
Perman,User,Model Name,
,Perman,Name

Is there a combination of formulas to do this? or with code in VBA?

CodePudding user response：

Please, try the next function:

Function replace0(x As String) As String
    Dim matches As Object, mch As Object, arr, k As Long
    ReDim arr(Len(x))
     With CreateObject("VbScript.regexp")
        .Pattern = "[0]{1,30}"
        .Global = True
        If .test(x) Then
            replace0 = .replace(x, ",")
        End If
     End With
End Function

It can be tested using:

Sub replaceAllzeroByComma()
   Dim x As String
   x = "000Perman00000000000000000000Name"
   'x = "000Model Test0Model Val00User0"
   'x = "Perman000User0Model Name000000"
   Debug.Print replace0(x)
End Sub

Uncheck the checked lines, one at a time and see the result in Immediate Window (Ctrl G, being in VBE)

CodePudding user response：

If you have Microsoft 365, you can use:

=IF(LEFT(A1)="0",",","")&TEXTJOIN(",",TRUE,TEXTSPLIT(A1,"0"))&IF(RIGHT(A1)="0",",","")

Split on the zero's
Join the split text with a comma delimiter
Have to specially test first character
and also the last character as pointed out by @T.M.

CodePudding user response：

Another option would be to check a character array:

Function Rep0(ByVal s As String, Optional del As String = "$DEL$")
    Dim tmp: tmp = String2Arr(s)        ' atomize string to character array
    Dim i As Long
    For i = LBound(tmp) To UBound(tmp)  ' check zero characters
        Dim old As String: CheckChar tmp, i, old, del
    Next
    tmp = Filter(tmp, del, False)       ' negative filtering preserving non-deletes
    Rep0 = Join(tmp, vbNullString)      ' return cleared string
End Function

Help procedures

Sub CheckChar(ByRef arr, ByVal i As Long, ByRef old As String, ByVal delete As String)
'Purp.: mark "0" characters in array depending on predecessors
        If Left(arr(i), 1) = "0" Then   ' omit possible string end character
            Select Case old
                Case "0", ",", delete: arr(i) = delete
                Case Else: arr(i) = ","
            End Select
        End If
        old = arr(i)                    ' remember prior character
End Sub

Function String2Arr(ByVal s As String)
'Purp.: atomize characters to array
    s = StrConv(s, vbUnicode)
    String2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function