Data separation

Hi All,

I have a large amount of data spread across multiple columns and rows. Unfortunately due to the output of the original program the data is output using commas as both decimal places and as separation devices. An image of the data is below:
Attachment 26747
Essentially the text columns should be changed to individual numbers that can be worked with, as per the below image:
Attachment 26748

As the commas are used as decimal separators as well as text separators, using the built in excel "text to column" is very difficult. I have created a vba code that separates the text strings, changes the commas to decimal separators, deletes the trailing decimal separator and then saves as a value. However this is very inefficient as it uses a "for each cell" loop. Can anyone suggest any improvements to my code to make it operate faster? Or if there is any bit of built in functionality that I may have missed that may assist? My code is below. I have also uploaded a sample set of data. It is not all the columns or rows but you get the idea of what it looks like to begin with.

Code:

---

Sub Data_Separation()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim rng As Range, cell As Range
Dim myStr As String
 
    ActiveSheet.Range("A2:A" & LastRow).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 9), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 9), Array(9, 9), Array(10, 9), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1)), _
        TrailingMinusNumbers:=True
   
    Set rng = ActiveSheet.UsedRange
         
        rng.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
   
    For Each cell In rng
        myStr = cell
        If Right(myStr, 1) = "." Then
            cell = Left(myStr, Len(myStr) - 1)
            cell.NumberFormat = "0.000"
            cell.Value = cell.Value
        End If
    Next cell
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

---

Quote:

---

Unfortunately the website is not letting me upload a txt file otherwise I would provide a small data sample.

---

Fake out the site by adding .zip to MyFile.txt making it MyFile.txt.zip

Just too hard to try and work with the picture

I know, 3 weeks later…
The attached has two offerings:
1. On Sheet1 there's a Power Query solution, which you'll need to right-click on (the table) and choose Refresh but it will balk, you need to follow this post to remedy that: http://www.vbaexpress.com/forum/show...l=1#post403062

2. A variation of your macro:

Code:

---

Sub Data_Separation2()
Dim rng As Range, cell As Range
Dim myStr As String
LastRow = 21    'added this manually since its value isn't known.
'looks like you have a header in row 1?
ActiveSheet.Range("A2:A" & LastRow).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 9), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 9), Array(9, 9), Array(10, 9), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1)), TrailingMinusNumbers:=True
   
Set rng = ActiveSheet.UsedRange    'assumes there's something in row 1 so:
With Intersect(rng, rng.Offset(1))    'to only process data body and not the headers.
  .Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
  zz = .Value
  For r = 1 To UBound(zz)
    For c = 1 To UBound(zz, 2)
      If Right(zz(r, c), 1) = "." Then zz(r, c) = Left(zz(r, c), Len(zz(r, c)) - 1)
    Next c
  Next r
  .Value = zz
  .NumberFormat = "0.000"
End With
End Sub

---

It should be much faster, without the need to disable calculation and screen updating. Try it on a copy of the Original sheet in the attached.

Simply use (fast as lightning):

Code:

---

Sub M_snb()
  With CreateObject("scripting.filesystemobject")
    .createtextfile("J:\temp\sample.csv").write Replace(Replace(Replace(Application.Trim(.opentextfile("J:\temp\sample.txt").readall), ", ", "_"), ",", "."), "_", ",")
  End With

  Workbooks.Open "J:\temp\sample.csv"
End Sub

---

Hey p45cal,

I admit project was a bit on hiatus and I only just just looked at this. It is definitely much faster! Thats awesome. I just need to modify a few little things but works well. Thank you so much.

Quote:

---

Originally Posted by snb

Simply use (fast as lightning):

Code:

---

Sub M_snb()
  With CreateObject("scripting.filesystemobject")
    .createtextfile("J:\temp\sample.csv").write Replace(Replace(Replace(Application.Trim(.opentextfile("J:\temp\sample.txt").readall), ", ", "_"), ",", "."), "_", ",")
  End With

  Workbooks.Open "J:\temp\sample.csv"
End Sub

---

---

I love the simplicity of this. Had a few issues with Microsoft Scripting not being enabled. But it still doesn't work. I keep getting a VBA Runtime Error 1004 “Application-defined or Object-defined error”. Not sure why...

In which line ?
Please be specific in your feedback.

Dit you check the availablitiy of the file you are going to process ?

What about ?

Code:

---

Sub M_snb()
  With CreateObject("scripting.filesystemobject")
    c00=Replace(Replace(Replace(Application.Trim(.opentextfile("J:\temp\sample.txt").readall), ", ", "_"), ",", "."), "_", ",")
    .createtextfile("J:\temp\sample.csv").write c00
  End With

  Workbooks.Open "J:\temp\sample.csv"
End Sub

---

In the first instance the error was located in the .CreateTextFile(.....).write Replace(....) line.
In the second sample the error persists. Located on line c00 = Replace(Replace(Replace(Application.Trim(.OpenTextFile(.........
There are several more columns and rows to the sample data set but this shouldn't make a difference to this method, should it? I also have a bunch of headers but even when removing those I still receive the error.

Did you adapt the filename ?
Post a sample file.

Quote:

---

Originally Posted by snb

Did you adapt the filename ?
Post a sample file.

---

FYI, after a little more digging into your suggestion, I got the code working. But it required some modification and expansion.
I am sure that it can be made a little more efficient but it works (and in a fraction of the time it originally took).

Code:

---

Dim objFSO
Const ForReading = 1
Const ForWriting = 2
Dim objTS
Dim strContents As String
Dim fileSpec As String


fileSpec = Application.GetOpenFilename()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTS = objFSO.OpenTextFile(fileSpec, ForReading)
strContents = objTS.ReadAll
strContents = Replace(Replace(strContents, ", ", ";"), ",", ".")
objTS.Close


Set objTS = objFSO.OpenTextFile(fileSpec, ForWriting)
objTS.Write strContents
objTS.Close
End Sub

---