Changing a long string of text

[SimonJ]

Hi

I have a cell of map coordinates that have to be in a certain format and contained in one cell in a text format. This format is pasted below (one cells worth of coordinates).

I need to take this data and limit down each coordinate to 5 decimal place while keeping in one cell.

Is there any quick way of doing this? A find and replace that will skip 5 digits and delete the rest? Any other ways i can do this quickly? Any ideas or pointing me in the right direction would be great.

-1.530125980547782,54.786940743685726 -1.530106134669028,54.786938420879544 -1.529578581360768,54.787001511999556 -1.529520686443149,54.786974515346309 -1.530100520535237,54.786416069326947 -1.530187344400296,54.786380649002382 -1.53020988731184,54.786371482709939 -1.530334037128598,54.786389931031884 -1.530402894896135,54.786422360103508 -1.530666211056607,54.78654654892383 -1.53071198516755,54.786612758267275 -1.530908929685753,54.786766786395681 -1.530893702064055,54.786786402522679 -1.530794274998956,54.786847289207522 -1.530448631327205,54.786779651036262 -1.53031701648107,54.786774649958453 -1.530291460338005,54.786800425014938 -1.530285426567772,54.786812170713127 -1.530229676249476,54.786887779983928 -1.530125980547782,54.786940743685726___

<tbody>
</tbody>

 

[Snakehips]

SimonJ,

I have assumed that all your initial data has 15 decimal places as per the example above.
Also, have coded for data being in column A. If not so then needs to be altered.
Code should shorten as you wish and overwrite the original data.

Test, thoughorly, on a small sample!!!

Sub Reduce()
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In Range("A1:A" & LastRow)  
If cell.Value = "" Then Exit Sub
Whole = ""
Arr1 = Split(cell)
For c = 0 To UBound(Arr1)
Arr2 = Split(Arr1(c), ",")
L = Len(Arr2(0)) - 10
Str1 = Left(Arr2(0), L)
L = Len(Arr2(0)) - 10
Str2 = Left(Arr2(1), L)
Part = Str1 & "," & Str2
Whole = Whole & " " & Part
Next c
cell.Value = Trim(Whole)
Next cell
Application.ScreenUpdating = True
End Sub

Hope that helps.

 

[SimonJ]

Hi Tony

That works perfectly. Thank you very much. You have saved me hours of frustration

Thanks Again

Simon

 

[Peter_SSs]

That works perfectly.

Are you sure. How exact do your results have to be? See below.

I have assumed that all your initial data has 15 decimal places as per the example

Unfortunately, they don't. See the red data for at least two that don't. The upshot is that some of the result items only have 4 decimal places not 5.

-1.530125980547782,54.786940743685726 -1.530106134669028,54.786938420879544 -1.529578581360768,54.787001511999556 -1.529520686443149,54.786974515346309 -1.530100520535237,54.786416069326947 -1.530187344400296,54.786380649002382 -1.53020988731184,54.786371482709939 -1.530334037128598,54.786389931031884 -1.530402894896135,54.786422360103508 -1.530666211056607,54.78654654892383 -1.53071198516755,54.786612758267275 -1.530908929685753,54.786766786395681 -1.530893702064055,54.786786402522679 -1.530794274998956,54.786847289207522 -1.530448631327205,54.786779651036262 -1.53031701648107,54.786774649958453 -1.530291460338005,54.786800425014938 -1.530285426567772,54.786812170713127 -1.530229676249476,54.786887779983928 -1.530125980547782,54.786940743685726___

<tbody>
</tbody>

Is there any quick way of doing this? A find and replace that will skip 5 digits and delete the rest? Any other ways i can do this quickly? Any ideas or pointing me in the right direction would be great.

You could also get ball-park results with this short code ..

Sub Reduce_v2()
  With Range("A1", Range("A" & Rows.Count).End(xlUp))
    .Replace What:="??????????,", Replacement:=",", LookAt:=xlPart, SearchFormat:=False, ReplaceFormat:=False
    .Replace What:="?????????? ", Replacement:=" ", LookAt:=xlPart, SearchFormat:=False, ReplaceFormat:=False
    .Value = Evaluate("=LEFT(" & .Address & ",LEN(" & .Address & ")-10)")
  End With
End Sub

.. but I think this will do more accurately what you have asked.

Sub Reduce_v3()
  Dim a, b
  Dim i As Long, j As Long, rws As Long
  
  With Range("A1", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    rws = UBound(a, 1)
    For i = 1 To rws
      b = Split(Replace(a(i, 1), ",", " ", 1, -1, 1))
      For j = 0 To UBound(b)
        b(j) = Format(b(j), "0.00000")
      Next j
      a(i, 1) = Replace(Join(b, ","), ",-", " -")
    Next i
    .Value = a
  End With
End Sub

 

[Firefly2012]

Assuming you don't need to worry about rounding that 5th decimal place then you could use this as an alternative too:

Sub Limit_Decimals()
Dim cell As Range
With CreateObject("vbscript.regexp")
    .Pattern = "(\.\d{5})\d+"
    .Global = True
    For Each cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        cell.NumberFormat = "@"
        cell.Value = .Replace(cell.Value, "$1")
    Next cell
End With
End Sub

 

[Firefly2012]

Assuming you don't need to worry about rounding that 5th decimal place then you could use this as an alternative too:

Sub Limit_Decimals()
Dim cell As Range
With CreateObject("vbscript.regexp")
    .Pattern = "(\.\d{5})\d+"
    .Global = True
    For Each cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        cell.NumberFormat = "@"
        cell.Value = .Replace(cell.Value, "$1")
    Next cell
End With
End Sub

Of course I've noticed a bit late that specifying Text format is a bad move when the data strings are > 255 characters. The following should be used instead:

Sub Limit_Decimals()
Dim cell As Range
With CreateObject("vbscript.regexp")
    .Pattern = "(\.\d{5})\d+"
    .Global = True
    For Each cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        cell.Formula = .Replace(cell.Value, "$1")
    Next cell
End With
End Sub

 

[Snakehips]

SimonJ,

How good is this forum!!!!!!

Metaphorically speaking, you had nothing but a pedal cycle.

I gave you with a, old Ford that turned out to be, a little bit, unreliable.

Peter traded you up to a sleeker vehicle.

Then Firefly treated you to a Ferrari!!!

 

[SimonJ]

Amazing!!!

The code is for an application where each longitude and latitude coordinate builds up an area on a map. The original piece of code took ages to run and the whole application suffered as a result. Unfortunately the coordinates have to be in that format to work and was going to take ages to fix, which is why no one had attempted before.

When they are limited to 5 decimal places, the mapping software speeds up and the accuracy is more than enough for what i'm trying to achieve.

Thank you all for your help. Its been a massive time saver.

Thank you again,

Simon

 

[Peter_SSs]

Metaphorically speaking, you had nothing but a pedal cycle.

I gave you with a, old Ford that turned out to be, a little bit, unreliable.

Peter traded you up to a sleeker vehicle.

Then Firefly treated you to a Ferrari!!!

Hmm, I'm not so sure about the analogy.
As it stands, Firefly's code is considerably slower than mine - at least with my tests (1,000 rows).
However, to be fair if I add ScreenUpdating off and on again to his code then our two codes time almost identically for me. So I'd like to be upgraded to a Ferrari too please.

What comes after a Ferrari?
If I combine techniques from Firefly's code and mine, this one runs in slightly less that half the time of our individual codes.

Sub Maserati()
  Dim a
  Dim i As Long, rws As Long

  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  rws = UBound(a, 1)
  With CreateObject("vbscript.regexp")
      .Pattern = "(\.\d{5})\d+"
      .Global = True
      For i = 1 To rws
          a(i, 1) = .Replace(a(i, 1), "$1")
      Next i
  End With
  Range("A1:A" & rws).Value = a
End Sub

 

[Snakehips]

Hey Peter,

I have to admit that I didn't actually test drive either of them. It's just that Firefly's looked like a Ferrari!!

I guess my eyesight is about on a par with my knowledge of Excel, better than some but nowhere near as good as many.

I take your word on the Maserati. It looks impressive but has technology under the bonnet that I know nothing about!!!