Consulting

Results 1 to 10 of 10

Thread: Data separation

  1. #1
    VBAX Regular
    Joined
    Jul 2016
    Posts
    18
    Location

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

    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
    Attached Files Attached Files
    Last edited by BeachBum; 05-27-2020 at 06:53 PM.

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    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:
    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.
    Attached Files Attached Files
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  4. #4
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

  5. #5
    VBAX Regular
    Joined
    Jul 2016
    Posts
    18
    Location
    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.

  6. #6
    VBAX Regular
    Joined
    Jul 2016
    Posts
    18
    Location
    Quote Originally Posted by snb View Post
    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...

  7. #7
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

  8. #8
    VBAX Regular
    Joined
    Jul 2016
    Posts
    18
    Location
    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.

  9. #9
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Did you adapt the filename ?
    Post a sample file.

  10. #10
    VBAX Regular
    Joined
    Jul 2016
    Posts
    18
    Location
    Quote Originally Posted by snb View Post
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •