Nightshade
Nightshade

Reputation: 3

Capping Consecutive delimiters during text file importing

Hey I am very new to VBA and trying to make the macro someone else made more universally able to handle different data files I work with. There are 2 main data file layouts one that uses consecutive space delimiters (up to 8 spaces) and one that is single space delimited which is fine but if the single space delimited data is missing info in one of the columns it uses specifically 11 spaces. Using the TextFileConsecutiveDelimiter = True code line it removes that column completely and the macro panics as it can not find the data as it shifts to far right in some cases.

Private Sub Cmdpopulate_Click()
filei = 0
filepath = InputBox("Please enter file path to be imported") & ""                                                                                        'asks user for the file path (the files should be named with integers sequentially)
filemax = InputBox("How many files do you wish to import?")                                                                                                                 'asks user how many files to import, this sets a maximum number to cycle through
Do While filei \< filemax                                                                                                                                                    'begins the file import loop, starting at filei (initially 0) up to filemax (defined above)
filei = filei + 1
filename = filei & ".txt"                                                                                                                                               'filename is the current filei integer and the extention
foffset = filei + 19
imptxt                                                                                                                                                                  'import file sub routine (see below)
Loop
add_frames
format_tables
Sheet1.Cells(1, 1).Select
'    cmdpopulate.Visible = False
End Sub

Public Sub imptxt()
Sheet2.Range("a4").CurrentRegion.Offset(500, 0).Resize(, 40).Clear                                                                                                          'clears the table
With Sheet2.QueryTables.Add(Connection:= \_
"TEXT;" & filepath & filename, Destination:=Sheet2.Range("$A$4"))
.Name = Sheet2.Range("b1").Value
.TextFilePlatform = 874
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileOtherDelimiter = "?"
.TextFileSpaceDelimiter = True
.TextFileConsecutiveDelimiter = True
.Refresh BackgroundQuery:=True
.RefreshStyle = xlOverwriteCells
End With                                                                                                                                                                    'opens file  filename (defined above) at filepath (defined above), delimites for '?' overwrites any data in existing cells
Sheet2.Range("a1") = filepath                                                                                                                                               'inserts filepath in cell a1, troubleshooting only
Sheet2.Range("a2") = filename                                                                                                                                               'inserts filename in cell b2, troubleshooting only
'  Sheet2.Select
If filei = 1 Then
headers
End If
send                                                                                                                                                                        'goes to the send subroutine to put data from the import table into the summary table
End Sub


This is the code I managed to do so far which works for 90% of the data but for a certain data structure (the one with the gaps) it gives a runtime error 13 type mismatch error pop-up in the part of the code that is taking the values from the query table that the above code creates and pasting them in a different sheet to summarise the data. I do not know if it is possible to get it to treat consecutive delimiters as one but also understand that 11 spaces means to leave a cell blank. Any help much appreciated. Sorry if the formatting is wrong first time posting here. I was asked to show some of the data sets I am using, below are the 3 types of data I am trying to get one set of code to work for (linked pictures of the .txt file and copy and pasted versions as the formatting is wrong on the copy pasted ones)

Data set (single space delimited)

Feature      Unit   Nominal    Actual      Tolerances      Deviation

Step 20 - 17 
Width         mm +017.00000 +016.91924 +00.20000 -00.20000 -000.08076       
 
Step 21 - 18 - Width 
Width         mm +014.00000 +014.00860 +00.20000 -00.20000 +000.00860       
 
Step 22 - 18 - Width 
Width         mm +014.00000 +013.98360 +00.20000 -00.20000 -000.01640         
 
Step 23 - 18 - Width
Width         mm +014.00000 +014.03760 +00.20000 -00.20000 +000.03760   

Data set (consecutive delimiters (6-8 spaces))

Feature    Unit    Nominal   Actual          Tolerances       Deviation 

Step 11 - 6.1   4.0 (+/- 0.4)
Radius      mm    +4.000    +4.111        +0.400      -0.400     +0.111          
   
Step 15 - 8   12 (+/- 0.4)
Radius      mm    +12.000   +12.407       +0.400      -0.400     +0.407           
   
Step 16 - 6.2  4 (+/- 0.4)
Radius      mm    +4.000    +3.890        +0.400      -0.400     -0.110               
   
Step 17 - 2 - 16.5 CtQ (+/- 0.5)
Max Width   mm    +16.500   +16.608       +0.500      -0.500     +0.108             
   
Step 19 - 6.3 - 4.0 (+/- 0.4)
Radius      mm    +4.112     +4.046      +0.400      -0.400     -0.066 

Data set that breaks it (has gaps that are always 11 spaces)

Feature      Unit  Nominal   Actual      Tolerances      Deviation   

Step 19 - Hole 11 - Dia
Diameter      in +0000.1630 +0000.1633 +000.0020 -000.0020 +0000.0003        
 
Step 20 - Hole 12 - Dia
Diameter      in +0000.1630 +0000.1634 +000.0020 -000.0020 +0000.0004   
 
Step 22 - Hole 1 - TP
True Positio  in    *(11 space)*        +0000.0010 +000.0100  *(11 space)*         +0000.0010    

Step 23 - Hole 2 - TP
True Positio  in     *(11 space)*       +0000.0027 +000.0100    *(11 space)*       +0000.0027     
 
Step 24 - Hole 3 - TP
X Location    in -0002.0460 -0002.0455    *(11 space)   (11space)*                  -0000.0005           
Y Location    in +0000.0000 -0000.0016    *(11 space)   (11space)               -0000.0016*           
True Positio  in     *(11space)*   +0000.0033 +000.0100 (11space)    +0000.0033        

Upvotes: 0

Views: 89

Answers (2)

Nightshade
Nightshade

Reputation: 3

I finally managed to get something to work mashing Taller's code (Thank you so much for that) with some other online code and the code the initial macro maker did. It is not a pretty solution and required a lot of editing of later subs to account for non-numerical values in calculations but here is my code mash that somehow worked

Dim filepath As String
Dim file As String
Dim filename As String
Dim filemax As Integer
Dim filei As Integer   
Dim TextFile As Integer
Dim FileContent As String

 Private Sub Cmdpopulate_Click()
        filei = 0
        filepath = InputBox("Please enter file path to be imported") & "\"                                                                                        'asks user for the file path (the files should be named with integers sequentially)
        filemax = InputBox("How many files do you wish to import?")                                                                                                                 'asks user how many files to import, this sets a maximum number to cycle through
        Do While filei < filemax                                                                                                                                                    'begins the file import loop, starting at filei (initially 0) up to filemax (defined above)
            filei = filei + 1
            filename = filei & ".txt"                                                                                                                                               'filename is the current filei integer and the extention
            foffset = filei + 19
            TextFile_FindReplace                                                                                                                                                                  'import file sub routine (see below)
        Loop
        add_frames
        format_tables
        Sheet1.Cells(1, 1).Select
    '    cmdpopulate.Visible = False
    End Sub
    Sub TextFile_FindReplace()
    
        file = filepath & "\" & filename
      TextFile = FreeFile
        Open file For Input As TextFile
            FileContent = Input(LOF(TextFile), TextFile)
        Close TextFile
      
            FileContent = Replace(FileContent, "          ", " --")
            TextFile = FreeFile
        Open file For Output As TextFile
            Print #TextFile, FileContent
        Close TextFile
        imptxt
    End Sub
    
    Public Sub imptxt()
        Sheet2.Range("a4").CurrentRegion.Offset(500, 0).Resize(, 40).Clear                                                                                                          'clears the table
        With Sheet2.QueryTables.Add(Connection:= _
            "TEXT;" & filepath & filename, Destination:=Sheet2.Range("$A$4"))
            .Name = Sheet2.Range("b1").Value
            .TextFilePlatform = 874
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileOtherDelimiter = "?"
            .TextFileSpaceDelimiter = True
            .TextFileConsecutiveDelimiter = True
            .Refresh BackgroundQuery:=True
            .RefreshStyle = xlOverwriteCells
        End With                                                                                                                                                                    'opens file  filename (defined above) at filepath (defined above), delimites for '?' and overwrites any data in existing cells
        Sheet2.Range("a1") = filepath                                                                                                                                               'inserts filepath in cell a1, troubleshooting only
        Sheet2.Range("a2") = filename                                                                                                                                               'inserts filename in cell b2, troubleshooting only
      '  Sheet2.Select                                                                                                                                                                  'goes to the send subroutine to put data from the import table into the summary table
        TextFile_Restore
    End Sub
    Sub TextFile_Restore()
        file = filepath & "\" & filename
      TextFile = FreeFile
        Open file For Input As TextFile
            FileContent = Input(LOF(TextFile), TextFile)
        Close TextFile
      
            FileContent = Replace(FileContent, " --", "          ")     'changing the document back
            TextFile = FreeFile
        Open file For Output As TextFile
            Print #TextFile, FileContent
        Close TextFile
         If filei = 1 Then
            headers
        End If
        send
    End Sub

I hope it never breaks as I don't think I would be able to do it again.

Upvotes: 0

taller
taller

Reputation: 18923

It seems the text files were exported from software or an application. If that’s the case, there’s likely no way to control how the system handles blank values during export.

Note: The script provides a basic solution but is not refined enough to import the data as a well-organized table on the worksheet. Issues such as spaces in the title row (e.g., Step 22 - Hole 1 - TP) and feature names (e.g., Y Location) may require additional script to process the imported data.

A possible solution would be to replace the 11 spaces with a placeholder before importing the file into Excel.

Public Sub imptxt()
    Dim filePath As String: filePath = "d:\temp\"  ' modify as needed
    Dim fileName As String: fileName = "test1.txt"
    Dim newName As String: newName = Replace(fileName, ".txt", "_fix.txt")
    Const PLACE_HOLDER = "##"
    Call ReplaceSpaces(filePath, fileName, newName)
    Sheet1.Cells.Clear
    With Sheet1.QueryTables.Add(Connection:= _
        "TEXT;" & filePath & newName, Destination:=Sheet1.Range("$A$4"))
        .Name = Sheet1.Range("b1").Value
        .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2)
        .TextFilePlatform = 874
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileOtherDelimiter = " "
        .TextFileSpaceDelimiter = True
        .TextFileConsecutiveDelimiter = True
        .Refresh BackgroundQuery:=True
        .RefreshStyle = xlOverwriteCells
    End With                                                                                                                
    Sheet1.Range("a1") = filePath
    Sheet1.Range("a2") = fileName
    Sheet1.UsedRange.Replace What:=PLACE_HOLDER, Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub
Sub ReplaceSpaces(filePath As String, fileName As String, newName As String)
    Dim inputFile As String
    Dim outputFile As String
    Dim fileContent As String
    Dim fileNum As Integer
    Const PLACE_HOLDER = "##"
    ' File paths
    inputFile = filePath & fileName
    outputFile = filePath & newName
    ' Open the input file for reading
    fileNum = FreeFile
    Open inputFile For Input As #fileNum
    fileContent = Input(LOF(fileNum), fileNum) ' Read the entire file
    Close #fileNum
    ' Replace 11 spaces with " ## "
    fileContent = Replace(fileContent, String(11, " "), Chr(32) & PLACE_HOLDER & Chr(32))
    ' Open the output file for writing
    fileNum = FreeFile
    Open outputFile For Output As #fileNum
    Print #fileNum, fileContent ' Write updated content to the new file
    Close #fileNum
End Sub


Output:

enter image description here

Upvotes: 1

Related Questions