remove o 0 à frente do decimal, exceto quando um número diferente de zero o precede

Question

Eu tenho uma coluna, que tem valores separados por vírgulas dentro de cada célula que se parecem com isso

0.1, 0.2,0.3, 0.4,0.5, 0.8,1.0
1.5, 1.6,2.0, 10.6,10.9, 15.2,30.75
20, 0.25,280.2, 0.29,300.2, 423,530.76

Como uma string de texto.

O objetivo é remover o zero inicial na frente do decimal, mas somente quando não houver outro dígito (incluindo outro 0) na frente dele Eu uso a função de substituição de pesquisa vba:     

    Option Explicit
    Public Sub Replace0dot(Optional byDummy As Byte)
        Columns("A").Replace What:"0.", _
                            Replacement:=".", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    Application.ScreenUpdating = True
    End Sub 

e eu acabo com isso:

.1, .2,.3, .4,.5, .8,1
1.5, 1.6,2, 1.6,1.9, 15.2,3.75
2, .25,28.2, .29,30.2, 423,53.76

Ele remove todas as instâncias de 0. com . , para que você veja 10.6 se tornar 1.6 . Mas deve permanecer 10.6 Como posso obter um equivalente de substituição de pesquisa que me dê:

.1, .2,.3, .4,.5, .8,1
1.5, 1.6,2, 10.6,10.9, 15.2,30.75
20, .25,280.2, .29,300.2, 423,530.76

??? Parece que teria que ser des-concatenar e re-concatenar para alcançar o objetivo.

    

Answer 1

Aqui está uma abordagem muito simples:

• se a string começar com 0. , em seguida, solte o zero
• se a string contiver triplets como {space} 0. e, em seguida, eliminar esse zero
• se a string contiver triplets como , 0. , em seguida, solte esse zero

Selecione as células e execute este código:

Sub fixdata()
    Dim r As Range, t As String

    For Each r In Selection
        t = r.Text
        If Left(t, 2) = "0." Then t = Mid(t, 2)
        t = Replace(t, " 0.", " .")
        t = Replace(t, ",0.", ",.")
        r.Value = t
    Next r
End Sub

antes:

edepois:

Sehouveroutrostriosquedevemseralterados,bastaadicionaroutroReplace()

EDIT#1:

Paraevitaraseleçãomanualdascélulas,podemosfazeramacrofazê-lo.........aquiestáumexemploparaacolunaA:

Subfixdata2()DimrAsRange,tAsStringForEachrInIntersect(Range("A:A"), ActiveSheet.UsedRange)
        t = r.Text
        If Left(t, 2) = "0." Then t = Mid(t, 2)
        t = Replace(t, " 0.", " .")
        t = Replace(t, ",0.", ",.")
        r.Value = t
    Next r
End Sub

EDIT # 2

Nesta versão, adicionamos um ; ao final de cada célula, antes de inserir o texto nessa célula:

Sub fixdata3()
    Dim r As Range, t As String, Suffix As String
    Suffix = ";"

    For Each r In Intersect(Range("A:A"), ActiveSheet.UsedRange)
        t = r.Text
        If Left(t, 2) = "0." Then t = Mid(t, 2)
        t = Replace(t, " 0.", " .")
        t = Replace(t, ",0.", ",.")
        r.Value = t & Suffix
    Next r
End Sub

EDIT3 #:

Nesta versão, o ; é acrescentado apenas se ainda não estiver presente na célula:

Sub fixdata4()
    Dim r As Range, t As String, Suffix As String
    Suffix = ";"

    For Each r In Intersect(Range("A:A"), ActiveSheet.UsedRange)
        t = r.Text
        If Left(t, 2) = "0." Then t = Mid(t, 2)
        t = Replace(t, " 0.", " .")
        t = Replace(t, ",0.", ",.")
        If Right(t, 1) <> Suffix Then
            r.Value = t & Suffix
        End If
    Next r
End Sub

EDIT # 4:

Esta versão não afetará as células vazias:

Sub fixdata5()
    Dim r As Range, t As String, Suffix As String
    Suffix = ";"

    For Each r In Intersect(Range("A:A"), ActiveSheet.UsedRange)
        t = r.Text
        If t <> "" Then
            If Left(t, 2) = "0." Then t = Mid(t, 2)
            t = Replace(t, " 0.", " .")
            t = Replace(t, ",0.", ",.")
            If Right(t, 1) <> Suffix Then
                r.Value = t & Suffix
            End If
        End If
    Next r
End Sub

EDIT # 5:

Isso corrige o bug na versão anterior:

Sub fixdata6()
    Dim r As Range, t As String, Suffix As String
    Suffix = ";"

    For Each r In Intersect(Range("A:A"), ActiveSheet.UsedRange)
        t = r.Text
        If t <> "" Then
            If Left(t, 2) = "0." Then t = Mid(t, 2)
            t = Replace(t, " 0.", " .")
            t = Replace(t, ",0.", ",.")
            If Right(t, 1) <> Suffix Then
                t = t & Suffix
            End If
            r.Value = t
        End If
    Next r
End Sub

    

Answer 2

Use este código VBA para testar cada seqüência de caracteres para zeros à esquerda

Sub Replace0dot()

   Dim str As String    
   Dim ln As Long   
   Dim i As Long    

   ln = Range("A1").End(xlDown).Row   
   For i = 1 To ln
   str = Cells(i, 1).Value
   If Left(str, 1) = "0" Then
   Cells(i, 1) = Mid(str, 2)
   End If
   Next i

End Sub   

    

Answer 3

Assumindo que você está ainda trabalhando com linhas de notepad ++ você pode usar uma matriz em vez de texto para colunas

Sub notepadthingrevisit()
    Dim workingRange As Range
    Set workingRange = Range("A1:A3")
    Dim i As Long
    Dim j As Long
    Dim result As String

    Dim myStrings() As String
    For i = 1 To workingRange.Rows.Count
        myStrings = Split(Cells(i, 1), ",")
        'Adjust this for accounting for the first value and remember to trim the " " at the end
        For j = 0 To UBound(myStrings)
            If Left(Trim(myStrings(j)), 1) = 0 Then
                myStrings(j) = Right(Trim(myStrings(j)), (Len(Trim(myStrings(j))) - 1))
            End If
            If myStrings(j) = Int(myStrings(j)) Then myStrings(j) = Int(myStrings(j))
            'Check here for j mod x and insert " "
            result = result & myStrings(j) & ","
        Next
        Cells(i, 5) = result
    Next

End Sub

Use apenas as informações do tópico anterior para inserir seus espaços.