Custom Report form Excel data to text file

Hi,

I have xls data file from which i want to create report just like mail merge but in txt file template.

can any one provide macro to generate report.

text file should auto save with file name "report & date" into in same folder where xls file.

attached sample file for your ref.

https://dl.dropbox.com/u/66400357/custome%20report.xlsx ( data file )
https://dl.dropbox.com/u/66400357/Report.txt ( required report in txt file )

any solution ???

Don't have time to do it for you right now but this is the concept.

[vba]Public lastStr As String, colNames, colStart, colLen

'Play from the Activesheet to insert parsed text file's contents
Sub ParseMyFile()
Dim inFile As String
Dim iStr As String
Dim fni As Integer

On Error GoTo Cleanup
'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
SpeedOn
'******************************** Set the path and name of the text file to parse ***********
inFile = ThisWorkbook.Path & Application.PathSeparator & _
"Rough data to excel.txt"

If Dir(inFile) = "" Then
MsgBox inFile & " does not exist.", vbCritical, "Macro Ending"
GoTo Cleanup
End If

colNames = Array("Country", "CLS", "Security", "Company", "Security Name", "Currency", _
"Market Price", "Last Price", "Market Price" & vbLf & "+ Accrued Price Rate", _
"Price Date", "7dp")
colStart = Array(1, 5, 9, 22, 53, 81, 85, 85, 102, 119, 129)
colLen = Array(3, 3, 12, 30, 27, 3, 14, 14, 16, 8, 1)

'Write field/column names to row 1 if A1 is empty
If IsEmpty(Range("A1")) Then
Range("A1").Resize(1, UBound(colNames) + 1).Value = colNames
End If

'Open inputfile. Parse input file's parts.
fni = FreeFile
Open inFile For Input As #fni
Line Input #fni, iStr
Do While Not EOF(fni)
'Parse lines and input to Range
ParseLine iStr
Line Input #fni, iStr
Loop
'Set formats and reset text strings to values
SetFormats

Cleanup:
On Error Resume Next
SpeedOff
If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & vbCrLf & Err.Description, , "Error"
Close #fni
End Sub

Sub ParseLine(str As String)
Dim i As Integer, r As Range
If Left(str, 5) <> "PRICE" Then
lastStr = str
Exit Sub
End If
Set r = Range("A" & Rows.Count).End(xlUp)
For i = 0 To UBound(colNames)
r.Offset(1, i).Value = Mid(lastStr, colStart(i), colLen(i))
Next i
'Reset Last Price value since it was on previous line in same position as Market Price.
r.Offset(1, 7).Value = Mid(str, colStart(7), colLen(7))
End Sub

Sub SetFormats()
Dim r As Range, d As Date
'Set columns G:I as money
Range("G2", Range("G" & Rows.Count).End(xlUp)).NumberFormat = "$#,##0.00"
Range("H2", Range("H" & Rows.Count).End(xlUp)).NumberFormat = "$#,##0.00"
Range("I2", Range("I" & Rows.Count).End(xlUp)).NumberFormat = "$#,##0.00"

'Parse column J to make into dates and format
For Each r In Range("J2", Range("J" & Rows.Count).End(xlUp))
With r
.NumberFormat = "dd-mm-yy"
If Not (IsEmpty(r)) Then
'Assume years are in this century
.Value = DateSerial(2000 + Right(.Value, 2), Mid(.Value, 4, 2), Left(.Value, 2))
End If
End With
Next r
End Sub


'If array is 0 based, 1 is returned if aValue matches anArray(0).
Function PosInArray(aValue, anArray)
Dim pos As Long
On Error Resume Next
pos = -1
pos = WorksheetFunction.Match(CStr(aValue), anArray, 0)
PosInArray = pos
End Function


[/vba]

See this link for the txt file. http://www.excelforum.com/excel-prog...-to-excel.html