I have a column, which has a comma separated values inside each cell that look like this
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
Like a text string.
The goal is to remove the leading zero in front of the decimal, but only when there is no other digit (including another 0) in front of it
I use the search replace function 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
and I end up with this:
.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
It removes all instances of leading 0. with ., so you see 10.6 becomes 1.6. But it should remain 10.6 How can I get a search replace equivalent that gives me:
.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
??? Seems like there would have to be un-concatenate and re-concatenate to achieve the goal.
Here is a very simple approach:
- if the string begins with 0. then drop the zero
- if the string contains triplets like {space}0. then drop that zero
- if the string contains triplets like ,0. then drop that zero
Select the cells and run this code:
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
before:
and after:
If there are other triplets that must be changed, just add another Replace()
EDIT#1:
To avoid manual selection of the cells, we can have the macro do it.........here is an example for column A:
Sub fixdata2()
Dim r As Range, t As String
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
Next r
End Sub
EDIT#2
In this version we append a ; to the end of each cell just before entering text into that cell:
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#:
In this version the ; is appended only if it not already present in the cell:
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:
This version will not affect empty cells:
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:
This fixes the bug in the previous version:
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
