Data separation

[BeachBum]

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:
26747
Essentially the text columns should be changed to individual numbers that can be worked with, as per the below image:
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.


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

[Paul_Hossler]

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

[p45cal]

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/showthread.php?67421-Import-txt-File-with-normal-Space-Delimiters&p=403062&viewfull=1#post403062

2. A variation of your macro:
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.

[snb]

Simply use (fast as lightning):


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

[BeachBum]

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.

[BeachBum]

Simply use (fast as lightning):


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...

[snb]

In which line ?
Please be specific in your feedback.

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

What about ?


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

[BeachBum]

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.

[snb]

Did you adapt the filename ?
Post a sample file.

[BeachBum]

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).



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