Writing Fixed width text files from excel vba - vba

This is the output of a program.
I have specified what shall be width of each cell in the program and my program shows correct output.
What I want to do is cell content shall be written from right to left. E.g highlighted figure 9983.54 has width of 21. Text file has used first 7 columns. But I want it to use last 7 columns of text file.
Please see expected output image.
I am not getting any clue how to do this. I am not a very professional programmer but I love coding. This text file is used as input to some other program and i am trying to automate writing text file from excel VBA.
Can anyone suggest a way to get this output format?
Here is the code which gave me first output
Option Explicit
Sub CreateFixedWidthFile(strFile As String, ws As Worksheet, s() As Integer)
Dim i As Long, j As Long
Dim strLine As String, strCell As String
'get a freefile
Dim fNum As Long
fNum = FreeFile
'open the textfile
Open strFile For Output As fNum
'loop from first to last row
'use 2 rather than 1 to ignore header row
For i = 1 To ws.Range("a65536").End(xlUp).Row
'new line
strLine = ""
'loop through each field
For j = 0 To UBound(s)
'make sure we only take chars up to length of field (may want to output some sort of error if it is longer than field)
strCell = Left$(ws.Cells(i, j + 1).Value, s(j))
'add on string of spaces with length equal to the difference in length between field length and value length
strLine = strLine & strCell & String$(s(j) - Len(strCell), Chr$(32))
Next j
'write the line to the file
Print #fNum, strLine
Next i
'close the file
Close #fNum
End Sub
'for example the code could be called using:
Sub CreateFile()
Dim sPath As String
sPath = Application.GetSaveAsFilename("", "Text Files,*.txt")
If LCase$(sPath) = "false" Then Exit Sub
'specify the widths of our fields
'the number of columns is the number specified in the line below +1
Dim s(6) As Integer
'starting at 0 specify the width of each column
s(0) = 21
s(1) = 9
s(2) = 15
s(3) = 11
s(4) = 12
s(5) = 10
s(6) = 186
'for example to use 3 columns with field of length 5, 10 and 15 you would use:
'dim s(2) as Integer
's(0)=5
's(1)=10
's(2)=15
'write to file the data from the activesheet
CreateFixedWidthFile sPath, ActiveSheet, s
End Sub

Something like this should work:
x = 9983.54
a = Space(21-Len(CStr(x))) & CStr(x)
Then a will be 14 spaces followed by x:
a = " 9983.54"
Here 21 is the desired column width --- change as necessary. CStr may be unnecessary for non-numeric x.
If you're going to right-justify a lot of different data to different width fields you could write a general purpose function:
Function LeftJust(val As String, width As Integer) As String
LeftJust = Space(width - Len(val)) & val
End Function
The you call it with LeftJust(CStr(9983.54), 21).
Also note that VBA's Print # statement has a Spc(n) parameter that you can use to produce fixed-width output, e.g., Print #fNum, Spc(n); a; before this statement you calculate n: n = 21-Len(CStr(a)).
Hope that helps

Related

VBA test format of text/value

I'm making a sub that exports a DXF file as text into my sheet and then take some values out of that.
I have two problems :
--> The first being how to keep the format of a value I export in a sheet?
--> And the second one being how to test the format of a value ?
I have different types of value in the file that I'm exporting :
Text
Integer "10", "20", "21" etc.. which tells me what kind of value comes after
Actual values that I want (which kind was given by the integer), written as xxx.xxxx ("0.0000", "50.0000" or 120.0000 for example so always 4 zeros after the dot)
In the file it looks like this :
CONTINUOUS
10
50.0000
20
120.0000
30
0.0000
40
50.0000
50
0.0000
51
180.0000
62
5
0
So my issue is that excel doesn't keep my values as they are when I export it. If it is 50.0000 it will write 50 and then I can't differentiate the types of the values... All the solution I found were about getting all my data as a format #.000 but that doesn't solve my problem...
Here is my sub :
Sub ImportDXF()
Dim fName As String
ActiveSheet.Columns(1).ClearContents
fName = Application.GetOpenFilename("DXF Files (*.dxf), *.dxf")
If fName = "False" Then Exit Sub
Dim v As Variant
Dim r As Long
r = 2 'from row 2
Open fName For Input As #1
Do While Not EOF(1)
Input #1, Line$
Rows(r).Columns(1) = Trim(Line$)
r = r + 1
Loop
Close #1
End Sub
And then I have another sub that will make something with the values I have exported so I want to test if this is an integer value or a float..
You'll have to test each value as you read it from the input DXF file. Then, apply an appropriate format to the cell with that value so it shows properly in your spreadsheet.
Sub ImportDXF()
Dim fName As String
ActiveSheet.Columns(1).ClearContents
fName = Application.GetOpenFilename("DXF Files (*.dxf), *.dxf")
If fName = "False" Then Exit Sub
Dim v As Variant
Dim r As Long
r = 2 'from row 2
Open fName For Input As #1
Do While Not EOF(1)
Input #1, Line$
If IsNumeric(Line$) Then
'--- we have a number, but what kind?
If InStr(1, Line$, ".", vbTextCompare) > 0 Then
'--- we have a VALUE, so format to show the decimals
Cells(r, 1).NumberFormat = "#0.0000"
Else
'--- we have a value ID, format with no decimals
Cells(r, 1).NumberFormat = "#0"
End If
Else
'--- we have text
Cells(r, 1).NumberFormat = "#"
End If
Cells(r, 1).Value = Trim(Line$)
r = r + 1
Loop
Close #1
End Sub

Export Excel data to fixed-width text file - field locations

Let me begin by saying I'm kind of new to working with delimited files. I am trying to emulate how a piece of software lays out a text file using Excel.
Here is the code I'm using to create a text file from the worksheet:
Sub Export_Selection_As_Fixed_Length_File()
' Dimension all variables.
Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String
Dim FileNum, ColumnCount, RowCount, FieldWidth As Integer
Dim sht As Worksheet
'Below are options incase you want to change the folder where VBA stores the .txt file
'We use ActiveWorkbook.Path in this example
'ActiveWorkbook.Path 'the activeworkbook
'ThisWorkbook.Path 'the workbook with the code
'CurDir 'the current directory (when you hit File|open)
'If a cell is blank, what character should be used instead
Filler_Char_To_Replace_Blanks = " "
'Check if the user has made any selection at all
If Selection.Cells.Count < 2 Then
MsgBox "Nothing selected to export"
Selection.Activate
End
End If
'This is the destination file name.
DestinationFile = ActiveWorkbook.Path & "/textfile.txt"
'Obtain next free file handle number.
FileNum = FreeFile()
' Turn error checking off.
On Error Resume Next
' Attempt to open destination file for output.
Open DestinationFile For Output As #FileNum
' If an error occurs report it and end.
If Err <> 0 Then
MsgBox "Cannot open filename " & DestinationFile
Selection.Activate
End
End If
' Turn error checking on.
On Error GoTo 0
' Loop for each row in selection.
For RowCount = 1 To Selection.Rows.Count
For ColumnCount = 1 To Selection.Columns.Count
CellValue = Selection.Cells(RowCount, ColumnCount).Text
If (IsNull(CellValue) Or CellValue = "") Then CellValue = Filler_Char_To_Replace_Blanks
FieldWidth = Cells(1, ColumnCount).Value
If (ColumnCount = Selection.Columns.Count) Then
Print #FileNum, Format$(CellValue, "!" & String(FieldWidth, "#")) & vbCrLf;
Else: Print #FileNum, Format$(CellValue, "!" & String(FieldWidth, "#"));
End If
Next ColumnCount
' Start next iteration of RowCount loop.
Next RowCount
' Close destination file.
Close #FileNum
Selection.Activate
Workbooks.OpenText Filename:=DestinationFile
End Sub
The software I'm trying to emulate has "data locations" and "field sizes." For example, one field has a data location of 77, which means it will start as the 77th character on the line in the text file. (I don't know how common this is, so if it's very common, please excuse the useless information.) And the field size is 12.
If that doesn't make sense, here's a screenshot of a text file. The first line shows what my VBA creates, and the second line is how I want it to look. How can I force the values on the worksheet to start at a certain position on the line based on the column it's in?
It looks like your first row in the selection contains the field's width FieldWidth = Cells(1, ColumnCount).Value. In your problem description you mentioned data locations and field sizes. You need to have this information some where. You could put it on another sheet in the file, which would let you adjust the output of text file, or you could put those values in your VBA code as constants, or your could create a Class. Using something like this will enable you can redefine the fields as needed. The example below uses a simple class and a few private functions in the module
In the example below you'll need to add a sheet named "FieldControl" and place the appropriate values in columns..See the GetFieldControl function. To test the code I used the following:
You'll need to add the following reference to your macro work book. In the VBA editor under the Tools menu select References, then when the dialog box appears select Microsoft Scripting Runtime. (Tools->References)
And with all things code related, there are improvements that could be made to this.
Good Luck with your efforts
The Class (Insert->Class) change the default name to clField (you can call it whatever you like but make sure to update the dim statement GetFieldControl function to match the name you gave it.)
Option Explicit
Public Enum eFieldType
Number
Text
End Enum
Public Name As String
Public Size As Long
Public StartPos As Long
Public Value As String
Public FieldType As eFieldType
The module with a few updates
Option Explicit
Option Base 1 'This makes any defined array start a 1 rather than 0
Sub Export_Selection_As_Fixed_Length_File()
' Dimension all variables.
Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String
Dim FileNum, ColumnCount, RowCount, FieldWidth As Integer
Dim sht As Worksheet
Dim outputRecord() As String
'Below are options in case you want to change the folder where VBA stores the .txt file
'We use ActiveWorkbook.Path in this example
'ActiveWorkbook.Path 'the activeworkbook
'ThisWorkbook.Path 'the workbook with the code
'CurDir 'the current directory (when you hit File|open)
'If a cell is blank, what character should be used instead
Filler_Char_To_Replace_Blanks = "+"
'Check if the user has made any selection at all
If Selection.Cells.Count < 2 Then
MsgBox "Nothing selected to export"
Selection.Activate
End
End If
'This is the destination file name.
DestinationFile = ActiveWorkbook.Path & "\textfile.txt" 'This was changed to the DOS version of directory separator
On Error GoTo catchFileOpenError 'Poor man's version of Try/Catch
'Get a FileSystemObject using the MSFT Scripting Runtime reference
Dim fd As Scripting.FileSystemObject
Set fd = New Scripting.FileSystemObject
Dim outputFile As Object
Set outputFile = fd.CreateTextFile(DestinationFile, True, False)
' Turn error checking on.
On Error GoTo 0
Dim record As Scripting.Dictionary
'Call a private function that gets the filed control information from the
'Sheet titled FieldControl and the associated range
Set record = GetFieldControl(ActiveWorkbook.Sheets("FieldControl").Range("A2:D7"))
'Declare enumerators to loop through the selection
Dim dataRow As Range
Dim dataFld As Range
'Declare the output buffer, 80 characters
Dim outputBuffer(80) As Byte
'loop thru the selection row by row
For Each dataRow In Selection.Rows
'Initialize buffer to empty value defined by the second parameter
Call InitOutputBuffer(outputBuffer, Filler_Char_To_Replace_Blanks)
'Loop thru each field in the row
For Each dataFld In dataRow.Columns
'Copy the input value into the output byte array
Call CopyStringToByteArray(outputBuffer, StrConv(Trim(CStr(dataFld.Value2)), vbFromUnicode), _
record(dataFld.Column).StartPos, record(dataFld.Column).FieldType, record(dataFld.Column).Size)
Next dataFld
'Write the record to the text file but first convert ASCII Byte to Unicode String
'Also this method places CR/LF as part of the output to the file
outputFile.WriteLine StrConv(outputBuffer, vbUnicode)
Next dataRow
' Close destination file.
outputFile.Close
Selection.Activate
Workbooks.OpenText Filename:=DestinationFile
Exit Sub
catchFileOpenError: 'Catch the error after trying if openning the file fails
On Error GoTo 0
MsgBox "Cannot open filename " & DestinationFile
Selection.Activate
End Sub
'***********************************************************************************
'*
'* PARAMETERS:
'* outBuf is the updated buffer
'* inBuf is the input buffer that needs to be copied to the output buffer (buffer)
'* startCol is the starting column for the field
'* fldTy is the field type as defined by the class enumerator eFieldType
'* fldLen is the length of the field as defined on the control sheet
Private Sub CopyStringToByteArray(ByRef outBuf() As Byte, ByRef inBuf() As Byte, _
ByVal startCol As Long, ByRef fldTy As eFieldType, ByVal fldLen As Long)
Dim idx As Long
If fldTy = Text Then 'Left Justified
For idx = LBound(inBuf) To UBound(inBuf)
outBuf(startCol) = inBuf(idx)
startCol = startCol + 1
Next idx
Else 'Right Justified
Dim revIdx As Long
revIdx = startCol + fldLen - 1
For idx = UBound(inBuf) To LBound(inBuf) Step -1
outBuf(revIdx) = inBuf(idx)
revIdx = revIdx - 1
Next idx
End If
End Sub
'***************************************************************************
'* InitOutputBuffer
'* PARAMETERS:
'* buffer is the buffer to initialize
'* initVal is a string containing the value used to initialize the buffer
Private Sub InitOutputBuffer(ByRef buffer() As Byte, ByVal initVal As String)
Dim byInitVal() As Byte 'Byte array to hold the values from the string conversion
byInitVal = StrConv(initVal, vbFromUnicode) 'convert the string into an ASCII array
Dim idx As Long
For idx = LBound(buffer) To UBound(buffer)
buffer(idx) = byInitVal(0)
Next idx
'buffer(81) = Asc(Chr(13)) 'Carriage Return Character
'buffer(82) = Asc(Chr(10)) 'Line Feed Character
End Sub
'*******************************************************************************
'*
'* GetFieldControl
'* PARAMETERS:
'* ctrlRng is the range on a worksheet where the field control info is
'* found
'* REMARKS:
'* The range needs to have the following columns: Name, Size, Start Postion
'* and Type. Type values can be Text or Number
Private Function GetFieldControl(ByRef ctrlRng As Range) As Scripting.Dictionary
Dim retVal As Scripting.Dictionary
Set retVal = New Scripting.Dictionary
'format of control range is : Name, Size, Start Position, Type
Dim fldInfoRow As Range
Dim fld As clField 'A class that holds the control values from the work sheet
Dim colCnt As Long: colCnt = 1 'Becomes the key for the dictionary
For Each fldInfoRow In ctrlRng.Rows
Set fld = New clField
fld.Name = fldInfoRow.Value2(1, 1) 'Name of field in data table
fld.Size = fldInfoRow.Value2(1, 2) 'Output Size of field
fld.StartPos = fldInfoRow.Value2(1, 3) 'Output starting position for this field
Select Case fldInfoRow.Value2(1, 4) 'Controls how the output value is formated
Case "Text" ' Text left justified, Numbers are right justified
fld.FieldType = Text
Case "Number"
fld.FieldType = Number
Case Default
fld.FieldType = Text
End Select
retVal.Add Key:=colCnt, Item:=fld 'Add the key and the fld object to the dictionary
colCnt = colCnt + 1 'This key value is mapped to the column number in the input data table
Next fldInfoRow
'Return the scripting Dictionary
Set GetFieldControl = retVal
End Function

Extract PDF table and insert into Excel

I have a PDF file that contains a table. I want to use Excel-VBA to search just the first column for an array of values. I have a work around solution at the moment. I converted the PDF to a text file and search it like that. The problem is sometimes these values can be found in multiple columns, and I have no way of telling which one it's in. I ONLY want it if it's in the first column.
When the PDF converts to text, it converts it in a way such that there is an unpredictable amount of lines for each piece of information, so I can't convert it back to a table in an excel sheet based on the number of lines (believe me, I tried). The current method searches each line, and if it sees a match, it checks to see if the two strings are the same length. But like I mentioned earlier, (in a rare case but it does happen) there will be a match in a column that is NOT the column I want to search in. So, I'm wondering, is there a way to extract a single column from a PDF? Or even the entire table as it stands?
Public Sub checkNPCClist()
Dim lines As String
Dim linesArr() As String
Dim line As Variant
Dim these As String
lines = Sheet2.Range("F104").Value & ", " & Sheet2.Range("F105").Value & ", " & Sheet2.Range("F106").Value & ", " & Sheet2.Range("F107").Value
linesArr() = Split(lines, ",")
For Each line In linesArr()
If line <> " " Then
If matchlinename(CStr(line)) = True Then these = these & Trim(CStr(line)) & ", "
End If
Next line
If these <> "" Then
Sheet2.Range("H104").Value = Left(these, Len(these) - 2)
Else: Sheet2.Range("H104").Value = "Nope, none."
End If
End Sub
Function matchlinename(lookfor As String) As Boolean
Dim filename As String
Dim textdata As String
Dim textrow As String
Dim fileno As Integer
Dim temp As String
fileno = FreeFile
filename = "C:\Users\...filepath"
lookfor = Trim(lookfor)
Open filename For Input As #fileno
Do While Not EOF(fileno)
temp = textrow
Line Input #fileno, textrow
If InStr(1, textrow, lookfor, vbTextCompare) Then
If Len(Trim(textrow)) = Len(lookfor) Then
Close #fileno
matchlinename = True
GoTo endthis
End If
End If
'Debug.Print textdata
Loop
Close #fileno
matchlinename = False
endthis:
End Function

Text File Column Data Extraction with Excel VBA

I have code below that extracts data from a text file and sends to a worksheet. Data sends to the worksheet but its a mess. I aim to extract certain columns of data in the text file. Data columns are space delimited and spacing differs between column but ea column has a heading. How can I complete my code to search text file by column header name and send data under that header to the worksheet? A typical header and columns of data underneath is shown below the code. Header blocks and associated data are repeated throughout the text file but are space delimited by rows. Above ea header band is an identifier for that block.
Sub test()
Dim Path As String
Dim textline As String
Dim arr() As String
Dim i As Long, j As Long
Path = whatever...
Open Path For Input As #1
i = 1
While EOF(1) = False
Line Input #1, textline
arr = Split(CStr(textline), " ")
For j = 1 To UBound(arr)
ActiveSheet.Cells(i, j).Value = arr(j - 1)
Next j
i = i + 1
Wend
Close #1
End Sub
Identifier 1.1
Heave /
Wave Ampl.
/--------------/
Ampl. Phase
0.123 42
0.131 72
0.433 55

loading formatted data in VBA from a text file

I'm looking for the best way of loading formatted data in VBA. I’ve spent quite some time trying to find the equivalent of C-like or Fortran-like fscanf type functions, but without success.
Basically I want to read from a text file millions of numbers placed on many (100,000’s) lines with 10 numbers each (except the last line, possibly 1-10 numbers). The numbers are separated by spaces, but I don’t know in advance the width of each field (and this width changes between data blocks).
e.g.
397143.1 396743.1 396343.1 395943.1 395543.1 395143.1 394743.1 394343.1 393943.1 393543.1
-0.11 -0.10 -0.10 -0.10 -0.10 -0.09 -0.09 -0.09 -0.09 -0.09
0.171 0.165 0.164 0.162 0.158 0.154 0.151 0.145 0.157 0.209
Previously I’ve used the Mid function but in this case I can’t, because I don’t know in advance the width of each field. Also it's too many lines to load in an Excel sheet. I can think of a brute force way in which I look at each successive character and determine whether it’s a space or a number, but it seems terribly clumsy.
I’m also interested in pointers on how to write formatted data, but this seems easier -- just format each string and concatenate them using &.
The following snippet will read whitespace-delimited numbers from a text file:
Dim someNumber As Double
Open "YourDataFile.txt" For Input As #1
Do While Not (EOF(1))
Input #1, someNumber
`// do something with someNumber here...`
Loop
Close #1
update: Here is how you could read one line at a time, with a variable number of items on each line:
Dim someNumber As Double
Dim startPosition As Long
Dim endPosition As Long
Dim temp As String
Open "YourDataFile" For Input As #1
Do While Not (EOF(1))
startPosition = Seek(1) '// capture the current file position'
Line Input #1, temp '// read an entire line'
endPosition = Seek(1) '// determine the end-of-line file position'
Seek 1, startPosition '// jump back to the beginning of the line'
'// read numbers from the file until the end of the current line'
Do While Not (EOF(1)) And (Seek(1) < endPosition)
Input #1, someNumber
'// do something with someNumber here...'
Loop
Loop
Close #1
You could also use regular expressions to replace multiple whitespaces to one space and then use the Split function for each line like the example code shows below.
After 65000 rows have been processed a new sheet will be added to the Excel workbook so the source file can be bigger than the max number of rows in Excel.
Dim rx As RegExp
Sub Start()
Dim fso As FileSystemObject
Dim stream As TextStream
Dim originalLine As String
Dim formattedLine As String
Dim rowNr As Long
Dim sht As Worksheet
Dim shtCount As Long
Const maxRows As Long = 65000
Set fso = New FileSystemObject
Set stream = fso.OpenTextFile("c:\data.txt", ForReading)
rowNr = 1
shtCount = 1
Set sht = Worksheets.Add
sht.Name = shtCount
Do While Not stream.AtEndOfStream
originalLine = stream.ReadLine
formattedLine = ReformatLine(originalLine)
If formattedLine <> "" Then
WriteValues formattedLine, rowNr, sht
rowNr = rowNr + 1
If rowNr > maxRows Then
rowNr = 1
shtCount = shtCount + 1
Set sht = Worksheets.Add
sht.Name = shtCount
End If
End If
Loop
End Sub
Function ReformatLine(line As String) As String
Set rx = New RegExp
With rx
.MultiLine = False
.Global = True
.IgnoreCase = True
.Pattern = "[\s]+"
ReformatLine = .Replace(line, " ")
End With
End Function
Function WriteValues(formattedLine As String, rowNr As Long, sht As Worksheet)
Dim colNr As Long
colNr = 1
stringArray = Split(formattedLine, " ")
For Each stringItem In stringArray
sht.Cells(rowNr, colNr) = stringItem
colNr = colNr + 1
Next
End Function