How to write a data to a text file (VBA)

Rhodie72

Rhodie72

Well-known Member
Joined
Apr 18, 2016
Messages
633
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2010
  7. 2007
  8. 2003 or older
Platform
  1. Windows
  2. Mobile
I need to write data to a text file as a data steam
I have written preliminary code to capute data in a spreadsheet but the ultimate goal is to write the data direct to a text file without using a spreadsheet.

currently the spreadsheet is just to verify that the data is being captured correctly but it needs to be written to an array and then output as a text file with a line that is the command for an AutoCAD script.
The source data
SOP1

184320.468

398332.116

77,135

SOP2

184324.959

398335.356

77,135

SOP3

184369.416

398248.340

77,135

SOP4

184317.345

398251.648

77,135

SOP1.5

184310.358

398252.072

77,135

SOP1.6

184311.268

398267.045

77,135

SOP1.7

184318.255

398266.620

77,135

SOP2.1

184356.47

398057.478

77,135

SOP2.2

184304.218

398060.209

77,135

SOP2.3

184306.115

398096.166

77,135

SOP2.4

184308.803

398099.982

77,135

SOP2.5

184309.881

398117.917

77,135

SOP2.6

184307.445

398121.375

77,135

SOP3.1

184357.481

398102.259

77,135

SOP3.2

184357.237

398098.266

77,135

SOP3.3

184311.084

398104.783

77,135

SOP3.4

184310.867

398100.789

77,135
Click to expand...
So far it produces this table
SOP1184320.468,398332.116
SOP2184324.959,398335.356
SOP3184369.416,398248.34
SOP4184317.345,398251.648
SOP1.5184310.358,398252.072
SOP1.6184311.268,398267.045
SOP1.7184318.255,398266.62
SOP2.1184356.47,398057.478
SOP2.2184304.218,398060.209
SOP2.3184306.115,398096.166
SOP2.4184308.803,398099.982
SOP2.5184309.881,398117.917
SOP2.6184307.445,398121.375
SOP3.1184357.481,398102.259
SOP3.2184357.237,398098.266
SOP3.3184311.084,398104.783
SOP3.4184310.867,398100.789

The data ouput format required for "MyFile.scr"

Rich (BB code): 
PLINE




184320.468,398332.116
184324.959,398335.356
184369.416,398248.34
184317.345,398251.648
184310.358,398252.072
184311.268,398267.045
184318.255,398266.62
184356.47,398057.478
184304.218,398060.209
184306.115,398096.166
184308.803,398099.982
184309.881,398117.917
184307.445,398121.375
184357.481,398102.259
184357.237,398098.266
184311.084,398104.783
184310.867,398100.789
The code so far..
VBA Code: 
Sub Adjust_ColWidth()
'
' Adjust_ColWidth Macro
' Autofit column width
'

'
    Columns("A:A").EntireColumn.AutoFit
End Sub
Public Sub Delete_Blanks()
'
' Delete_Blanks Macro
' Deletes blanks in selection
'

'
    With Selection
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    'Application.CutCopyMode = False
End Sub
Sub Reorder_Data()
'
' Reorder_Data Macro
' Reorders data secions to correct places
'
Dim N
'
    Run "Adjust_ColWidth"
    Run "Delete_Blanks"
    Range("A1").Select
    Run "Arrange_SOP_Data"
    With Selection
        .Copy
        N = .Count - 1
        MsgBox "There are " & N & " lines of data to export", vbInformation, "Data Check"
    End With
    Application.CutCopyMode = False
'   Export dataset to script file for AutoCAD
End Sub
Public Sub Delete_cells_up()
'
' Delete_cells_up Macro
' Deletes empty cells
'

'
    With Selection
        .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        .End(xlUp).Select
    End With
End Sub

Public Sub Arrange_SOP_Data()
    Dim SOP_Data As Variant, X As Variant, Y As Variant

    Do Until Left(ActiveCell.Offset(1, 0).Value, 3) = ""
        If Left(ActiveCell.Value, 3) = "SOP" Then
            X = ActiveCell.Offset(1, 0).Text: Y = ActiveCell.Offset(2, 0).Text
            SOP_Data = Array(X, ",", Y)
            With ActiveCell
                .Offset(0, 1).Value = SOP_Data(0) & SOP_Data(1) & SOP_Data(2)
                Range(.Offset(1, 0), .Offset(3, 0)).EntireRow.Delete
                .Offset(1, 0).Select
            End With
        Else
            Stop
            
            Do Until Left(ActiveCell.Value, 3) = "SOP"
                ActiveCell.Offset(1, 0).Select
            Loop
            If Left(ActiveCell.Offset(1, 0).Value, 3) <> "SOP" Then
                X = ActiveCell.Offset(1, 0).Value: Y = ActiveCell.Offset(2, 0).Value
                SOP_Data = Array(X, ",", Y)
            End If
        End If
    Loop
    
    With Range("B1", ActiveCell.Offset(-1, 1))
        .Select
        Y = .Count
        .EntireColumn.AutoFit
        MsgBox Y
    End With
End Sub

My aim is literally to capture the reordered data of co-ordinates add the command to the first output, add a new line, append rthe file with each pair of cordinates then close the file.
Anybody up for this task to help out? The person who does this will discover what impact they have had on a major construction project, so there's a bragging right attached.
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
I don't know what end-of-line character is accepted in *.scr file. I used vbCrLf. If it has to be different, try changing it to vbCr or vbLf. Also adjust the paths and file names.
VBA Code: 
Sub AAA()
    Dim v As Variant
    Dim i As Long
    Dim strOut As String
    
    Const EndOfLine As String = vbCrLf 'or vbCr or vbLf
    
    v = TakeFromFile("d:\Test\InputFileName.txt")
    
    strOut = "PLINE" & EndOfLine
    
    For i = 0 To UBound(v) Step 8
        strOut = strOut & (v(i + 2) & "," & v(i + 4) & EndOfLine)
    Next i
    
    strOut = Left(strOut, Len(strOut) - Len(EndOfLine))
    
    Call WriteToFile("d:\Test\MyFile.scr", strOut)
    
    MsgBox "Done"
End Sub


Function TakeFromFile(strFilename As String) As Variant
    Dim iFn As Integer
    Dim strFileContent As String
    Dim varrTmp As Variant

    iFn = FreeFile

    Open strFilename For Input As #iFn
    strFileContent = Input(LOF(iFn), iFn)
    Close #iFn

    varrTmp = Split(strFileContent, vbCrLf)

    TakeFromFile = varrTmp
End Function


Sub WriteToFile(FileName As String, Data As String)
    Dim iFn As Integer
    
    iFn = FreeFile
    
    Open FileName For Output Access Write As #iFn
            
    Print #iFn, Data
    
    Close #iFn

End Sub
Artik
 
Upvote 0
Your code for Sub Reorder_Data() assumes that the data to export has already been selected . This rewrite assumes that the export data will be contained in the 2nd column of that selection. If that is not the case, you many need to tweak it. You will also need to edit your own value for variable ExportFolder.

VBA Code: 
Sub Reorder_Data()
    '
    ' Reorder_Data Macro
    ' Reorders data secions to correct places
    '
    Dim N
    Dim ExportRange As Range, R As Range
    Dim ExportFolder As String, FilePath As String, TextLine As String, Msg As String
    Dim FNumW As Integer
    
    Run "Adjust_ColWidth"
    Run "Delete_Blanks"
    Range("A1").Select
    Run "Arrange_SOP_Data"
    
    'Export dataset to script file for AutoCAD
    With Selection
        '.Copy
        Set ExportRange = .Resize(, 1).Offset(0, 1)
        N = .EntireRow.Count ' - 1
    End With
    
    Msg = "There are " & N & " lines of data selected for export" & vbCr & vbCr & "Export Data?"
    
    If ExportRange.Rows.Count > 1 Then
        Select Case MsgBox(Msg, vbYesNo Or vbQuestion, "Export Range: " & ExportRange.Address)
            Case vbYes
                ExportFolder = VBA.CurDir               '<---- CurDir is a placeholder. Edit this line to define folder for .scr file
                FilePath = ExportFolder & "\MyFile.scr"
                FNumW = FreeFile
                Open FilePath For Output Access Write As #FNumW    ' Open text file for write
                For Each R In ExportRange
                    TextLine = Trim(R.Value)
                    Print #FNumW, TextLine                        ' Write to output file
                Next R
                Close #FNumW                                      ' Close file.
            Case vbNo
                ' Do nothing
        End Select
    Else
        MsgBox "More than one line must be selected for export"
    End If
    Application.CutCopyMode = False
End Sub
 
Upvote 0
Thanks guys. Will teat in the morning
 
Upvote 0
rlv01 said:
Your code for Sub Reorder_Data() assumes that the data to export has already been selected . This rewrite assumes that the export data will be contained in the 2nd column of that selection. If that is not the case, you many need to tweak it. You will also need to edit your own value for variable ExportFolder.

VBA Code: 
Sub Reorder_Data()
    '
    ' Reorder_Data Macro
    ' Reorders data secions to correct places
    '
    Dim N
    Dim ExportRange As Range, R As Range
    Dim ExportFolder As String, FilePath As String, TextLine As String, Msg As String
    Dim FNumW As Integer
   
    Run "Adjust_ColWidth"
    Run "Delete_Blanks"
    Range("A1").Select
    Run "Arrange_SOP_Data"
   
    'Export dataset to script file for AutoCAD
    With Selection
        '.Copy
        Set ExportRange = .Resize(, 1).Offset(0, 1)
        N = .EntireRow.Count ' - 1
    End With
   
    Msg = "There are " & N & " lines of data selected for export" & vbCr & vbCr & "Export Data?"
   
    If ExportRange.Rows.Count > 1 Then
        Select Case MsgBox(Msg, vbYesNo Or vbQuestion, "Export Range: " & ExportRange.Address)
            Case vbYes
                ExportFolder = VBA.CurDir               '<---- CurDir is a placeholder. Edit this line to define folder for .scr file
                FilePath = ExportFolder & "\MyFile.scr"
                FNumW = FreeFile
                Open FilePath For Output Access Write As #FNumW    ' Open text file for write
                For Each R In ExportRange
                    TextLine = Trim(R.Value)
                    Print #FNumW, TextLine                        ' Write to output file
                Next R
                Close #FNumW                                      ' Close file.
            Case vbNo
                ' Do nothing
        End Select
    Else
        MsgBox "More than one line must be selected for export"
    End If
    Application.CutCopyMode = False
End Sub
Click to expand...
This is a workable solution. I would like to be able to open a file dialog box to grapically locate where the file is to be written. Every file has to be written to a different folder and all of them are not on my local machine.
 
Upvote 0
Artik said:
I don't know what end-of-line character is accepted in *.scr file. I used vbCrLf. If it has to be different, try changing it to vbCr or vbLf. Also adjust the paths and file names.
VBA Code: 
Sub AAA()
    Dim v As Variant
    Dim i As Long
    Dim strOut As String
   
    Const EndOfLine As String = vbCrLf 'or vbCr or vbLf
   
    v = TakeFromFile("d:\Test\InputFileName.txt")
   
    strOut = "PLINE" & EndOfLine
   
    For i = 0 To UBound(v) Step 8
        strOut = strOut & (v(i + 2) & "," & v(i + 4) & EndOfLine)
    Next i
   
    strOut = Left(strOut, Len(strOut) - Len(EndOfLine))
   
    Call WriteToFile("d:\Test\MyFile.scr", strOut)
   
    MsgBox "Done"
End Sub
[QUOTE="Artik, post: 6194718, member: 218006"]
I don't know what end-of-line character is accepted in *.scr file. I used vbCrLf. If it has to be different, try changing it to vbCr or vbLf. Also adjust the paths and file names.
[CODE=vba]
Sub AAA()
    Dim v As Variant
    Dim i As Long
    Dim strOut As String
   
    Const EndOfLine As String = vbCrLf 'or vbCr or vbLf
   
    v = TakeFromFile("d:\Test\InputFileName.txt")
   
    strOut = "PLINE" & EndOfLine
   
    For i = 0 To UBound(v) Step 8
        strOut = strOut & (v(i + 2) & "," & v(i + 4) & EndOfLine)
    Next i
   
    strOut = Left(strOut, Len(strOut) - Len(EndOfLine))
   
    Call WriteToFile("d:\Test\MyFile.scr", strOut)
   
    MsgBox "Done"
End Sub


Function TakeFromFile(strFilename As String) As Variant
    Dim iFn As Integer
    Dim strFileContent As String
    Dim varrTmp As Variant

    iFn = FreeFile

    Open strFilename For Input As #iFn
    strFileContent = Input(LOF(iFn), iFn)
    Close #iFn

    varrTmp = Split(strFileContent, vbCrLf)

    TakeFromFile = varrTmp
End Function


Sub WriteToFile(FileName As String, Data As String)
    Dim iFn As Integer
   
    iFn = FreeFile
   
    Open FileName For Output Access Write As #iFn
           
    Print #iFn, Data
   
    Close #iFn

End Sub
Artik
Click to expand...



Function TakeFromFile(strFilename As String) As Variant
Dim iFn As Integer
Dim strFileContent As String
Dim varrTmp As Variant

iFn = FreeFile

Open strFilename For Input As #iFn
strFileContent = Input(LOF(iFn), iFn)
Close #iFn

varrTmp = Split(strFileContent, vbCrLf)

TakeFromFile = varrTmp
End Function


Sub WriteToFile(FileName As String, Data As String)
Dim iFn As Integer

iFn = FreeFile

Open FileName For Output Access Write As #iFn

Print #iFn, Data

Close #iFn

End Sub[/CODE]
Artik
[/QUOTE]

I like where this is going but your code is working with this data from a text file whereas it is in the spreadsheet:
SOP1

184320.468

398332.116

77,135

SOP2

184324.959

398335.356

77,135

SOP3
Click to expand...
Which doesn't help

Maybe I need to explain deeper.
I use Google translate to capture the data by camera; it then gets pasted into Whatsapp and sent to my work account. I open whatsapp on my computer, copy & Paste the data directly into Excel (as above). Why? This method allows me to capture the data from both digital and paper sources and deliver in the same format every time.
The VBA script is to collate the correct elements into co-ordinates but disregard irrelevant info.

The PLINE command is for AutoCAD, then a new empty line followed by coordinates. Drag & drop this script file into AutoCAD and it then draws the line to each coordinate in milliseconds. The entire process of data capture is massively reduced in time and that's saving about £12000 an hour in client costs.
 

Attachments

  • 640x480_1692943624_aerial-view-of-first-completed-water-orton-viaduct-pier.jpg
    640x480_1692943624_aerial-view-of-first-completed-water-orton-viaduct-pier.jpg
    136.3 KB · Views: 7
Upvote 0
Sektor said:
What format your original data is in?
Click to expand...
a picture. It could be given to me in any format, but my method will always be consistent in exporting the correct data 100% of the time. It will always appear either on a screen or on paper in every drawing. The key data extaction is the X,Y co-ordinates. There are over 15,000 of these tables to collate and each coordinate has 21 charaters, which means millions of characters. We do not have 5.2 years to do this on this project. I got about 10 days at best.

1719408339976.png
 
Last edited:
Upvote 0
Maybe this picture will give a learer understanding of what I want VBA to achieve...
1719409234923.png
 
Upvote 0
Rhodie72 said:
I would like to be able to open a file dialog box to grapically locate where the file is to be written.
Click to expand...

In Sub Reorder_Data() Replace this line
VBA Code: 
ExportFolder = VBA.CurDir               '<---- CurDir is a placeholder. Edit this line to define folder for .scr file
with this one
VBA Code: 
ExportFolder = GetFolder(CurDir)  '<--- Edit to suit.

Include this function.
VBA Code: 
Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String

    strPath = Trim(strPath)
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a folder to save the file in"
        .AllowMultiSelect = False
        Do While Right(strPath, 1) = "\"
            strPath = Left(strPath, Len(strPath) - 1)
        Loop
        .InitialFileName = strPath & "\"              '.InitialFileName always needs to end with a backslash "\"
        .ButtonName = "Select"
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
Splitting up an excel file to multiple tabs by "visible" rows.
2
Replies
11
Views
194
BasicUserWithExp
B
H
  • Question Question
Advanced Multi VBA - Creating multiple temporary files and attach them to one email on outlook
Replies
2
Views
261
Hayf13
H
C
  • Solved
User Select PDF import to specific Excel sheet
2 3 4
Replies
31
Views
1K
John_w
J
T
  • Question Question
VBA to update Powerpoint Text from Excel Data in Cells
Replies
9
Views
967
tbakbradley
T
E
  • Solved
Force Excel 2019 VBA to import multiple txt file to existing sheet & not seperate wk.book / wk.sheets
Replies
1
Views
594
Domenic
D

Forum statistics

Threads
1,223,864
Messages
6,175,056
Members
452,607
Latest member
OoM_JaN

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top