write out a flat file with fixed columns

[Steve]

I would like to write a macro that writes a flat file that
is not tab or comma delimited, but has columns start at
specific locations. For example, everything in column A
of the spreadsheet will always start at column 1 of the
flat file. Everything in column B in the spreadsheet will
be written starting in column 15 of the flat file... C in
20, D in 30 ...

What is the code to place the Excel columns into the flat
file columns?

Thanks
Steve

 

[Ronald Dodge]

You could use the Choose worksheet function within VBA, so as once you have
the column letter converted to the column number, which can be done by the
Column Property of the cell object, you will then retrieve the appropriate
number from within the Choose function

Excel.WorksheetFunction.Choose(<ColumnNumber>,<Value1>[,<Value2>[,<Value3>[,
....]]])

Choose function can only contain up to 29 values, which means this will only
work for Excel columns A:AC. If you require a greater range, you will need
to setup a table type format for converting from Excel column to the flat
file column number, which could be done either within an Excel worksheet or
by using an array in VBA, though may be easier to setup one in an Excel
worksheet depending on what you require.

 

[Trevor Shuttleworth]

Steve

give this a go. You'll need to adjust the spacing as appropriate.

Sub WriteFixedFile()
Dim LastRow As Long
Dim i As Long
Dim sRecord As String
LastRow = Range("A65536").End(xlUp).Row
Open "c:\TESTFILE" For Output As #1 ' Open file for output.
For i = 1 To LastRow
sRecord = Range("A" & i).Value & Space(15 - Len(Range("A" & i)))
sRecord = sRecord & Range("B" & i).Value & Space(5 - Len(Range("B" &
i)))
sRecord = sRecord & Range("C" & i).Value & Space(10 - Len(Range("C" &
i)))
sRecord = sRecord & Range("D" & i).Value & Space(15 - Len(Range("D" &
i)))
'Write #1, sRecord ' data surrounded by quotes
Print #1, sRecord ' no quotes
Next 'i
Close #1
End Sub

Regards

Trevor

 

[Tom Rollins]

Here is a function that I found and modified to allow setting the column
widths and whether the info is justified left or right in the column.
===========================
Private Function pfRangeToFile(rngRange As Range, strFile As String, _

Optional strDelimiter As Variant, Optional _

strEncloser As Variant) As Boolean

'===========================================================

'= Procedure: pfRangeToFile
=

'= Procedure Type: Private Function
=

'=
=

'= Version: 1.0.0 at 18/06/98
=

'= Action: Initial Write
=

'= Author: Robert Bruce
=

'=
=

'= Description: Converts a worksheet range into a character
=

'= separated text file.
=

'= Arguments: rngRange - Range - the range to export. strFile -
=

'= string - the name of the export file to create.
=

'= strDelimiter - Optional string - the delimiting
=

'= character: Defaults to comma. strEncloser -
=

'= Optional string - the enclosing character for each
=

'= field: defaults to empty string
=

'= Returns: Boolean - True if export was successful.
=

'=
=

'=========================================================================

Dim intFileNum As Integer

Dim intRowCount As Integer, intColCount As Integer

Dim strTemp As String, strDlmtr As String, strEnclsr As String

On Error GoTo pfRangeToFileError

' Make sure option values/defaults are set

If IsMissing(strDelimiter) Then strDlmtr = "," Else _

strDlmtr = strDelimiter

If IsMissing(strEncloser) Then strEnclsr = "" Else _

strEnclsr = strEncloser

' Get free file number

intFileNum = FreeFile()

' Open the file

Open strFile For Output As #intFileNum

' Loop through range constructing delimited string for

' each row.

For intRowCount = 1 To rngRange.Rows.Count

' Initialise temp string

strTemp = ""

For intColCount = 1 To rngRange.Columns.Count

' If we're not looking at the first column then we need

' to add a delimeter

If Not intColCount = 1 Then strTemp = strTemp & strDlmtr

'--------------- ADDED CODE ------

stradd = ""

Select Case intColCount 'ADD COLUMN WIDTH AND LEFT/RIGHT PARAMETERS
PER COLUMN

Case 1

strlen = 9

strlft = 1


Case 2

strlen = 13

strlft = 1


Case 3

strlen = 1

strlft = 1


Case 4

strlen = 8

strlft = 0


Case 5

strlen = 9

strlft = 1


Case 6

strlen = 16

strlft = 1

Case 7

strlen = 2

strlft = 1

Case 8

strlen = 1

strlft = 1

stradd = "000000000000"

End Select


If strlen - Len(rngRange.Cells(intRowCount, intColCount).Value) > 0 Then

numadd = strlen - Len(rngRange.Cells(intRowCount, intColCount).Value)

Else

numadd = 0

End If


stradd = stradd & Space(numadd)

' Add the value in the column - PUT TO THE LEFT OF VALUE IF STRLFT=0

If strlft = 1 Then

strTemp = strTemp & strEnclsr & rngRange.Cells(intRowCount,
intColCount).Value & strEnclsr & stradd

Else

strTemp = strTemp & strEnclsr & stradd & rngRange.Cells(intRowCount,
intColCount).Value & strEnclsr

End If

'------------------------------------------------

Next intColCount

' Print the whole row to the file

Print #intFileNum, strTemp & ""

' Next row

Next intRowCount

' Close the file

Close #intFileNum

' All OK if we've reached here

pfRangeToFile = True

Exit Function

pfRangeToFileError:

' Show error message

MsgBox "Export Failed: The VB Error Was As Follows:" & _

Chr(13) & Error(Err), vbCritical

pfRangeToFile = False

End Function

==========================================