karthikn7974
Joined: 03 Jun 2008
Posts: 1
Location: singapore
|
 Posted: Tue Jun 03, 2008 8:53 am Post subject: Text to excel |
 |
|
hi all
i am using the below code to generate an excel file from a text file.
the fixed width is not unique and so need some help how to rectify this.
Text file contents as follows
| Code: |
05/22/2008 07:38:53 Server1 Client1 CLASS A 67
05/22/2008 07:38:53 Server2 Client2 CLASS B 86
05/22/2008 07:38:53 Server3 Client3 CLASS C 2
05/23/2008 07:38:53 Server1 Client1 CLASS A 0
05/23/2008 07:38:53 Server2 Client2 CLASS B 0
05/25/2008 07:38:53 Server3 Client3 CLASS C 2
05/26/2008 07:38:53 Server1 Client1 CLASS A 67
|
| Code: |
Option Explicit
Dim Excel As Excel.Application
Dim ExcelWBk As Excel.Workbook
Dim xlFileName As String
Dim txtFN As String
Dim fs As FileSystemObject
Dim txt As TextStream
Dim cn1 As ADODB.Connection
Dim rs1 As ADODB.Recordset
Dim dt As String
Private Sub CmdExit_Click()
End
End Sub
Private Sub CmdGenerate_Click()
Cmd_Final_Msg.Visible = False
Command1.Visible = True
ProgressBar1.Visible = True
ProgressBar1.Value = 30
'Variable equals text in textbox
File_Name.Text = "Report" + Format(Date, "ddMMMyy")
'File_Name.Text = "report"
'MsgBox File_Name.Text
xlFileName = File_Name.Text
'Open Microsoft Excel and set it equal to Excel
Set Excel = CreateObject("Excel.Application")
'Open Excel Workbook Template (Read Only)
Set ExcelWBk = Excel.Workbooks.Open(App.Path & "\" & "Template.xlt", ReadOnly:=True)
'Save Template as file name added in TextBox
ExcelWBk.SaveAs (App.Path & "\" & xlFileName)
ExcelWBk.Close
With Excel
'Do not show WorkBook
.Visible = False
'Close Microsoft Excel
.Quit
End With
'Clear the Textbox
mainRpt
File_Name.Text = ""
'ExcelWBk.Close
' ExcelWBk.Application.Quit
Set ExcelWBk = Nothing
Set Excel = Nothing
ProgressBar1.Value = 40
End Sub
Private Sub CmdHelp_Click()
MsgBox "*** Coded by KARTHIK - www.karthik.sg ***"
End Sub
Private Function mainRpt()
ProgressBar1.Value = 60
Set cn1 = New ADODB.Connection
Set rs1 = New ADODB.Recordset
dt = "Report" + Format(Date, "ddMMMyy")
cn1.Provider = "Microsoft.Jet.OLEDB.4.0"
cn1.Open "data source= " & App.Path & "\" & dt & ".xls;extended properties = Excel 8.0;"
Set fs = New FileSystemObject
CommonDialog1.ShowOpen
txtFN = CommonDialog1.FileName
'Set txt = fs.OpenTextFile(App.Path & "/Export.txt", ForReading)
Set txt = fs.OpenTextFile(txtFN, ForReading)
ProgressBar1.Value = 80
Dim str As String
Dim cnt As Integer
Dim fcolumn As Variant
cnt = 0
str = ""
Do While Not (txt.AtEndOfStream)
cnt = cnt + 1
str = txt.ReadLine
'str = Replace(str, " ", "@")
If cnt >= 7 Then
ReDim fcolumn(0)
ReDim Preserve fcolumn(0)
fcolumn(0) = Trim(Mid(str, 1, 9))
ReDim Preserve fcolumn(1)
fcolumn(1) = Trim(Mid(str, 10, 11))
ReDim Preserve fcolumn(2)
fcolumn(2) = Trim(Mid(str, 21, 11))
ReDim Preserve fcolumn(3)
fcolumn(3) = Trim(Mid(str, 32, 30))
ReDim Preserve fcolumn(4)
fcolumn(4) = Trim(Mid(str, 52, 17))
ReDim Preserve fcolumn(5)
fcolumn(5) = Trim(Mid(str, 68, 32))
'ReDim Preserve fcolumn(6)
'fcolumn(6) = Trim(Mid(str, 108, 9))
''
'ReDim Preserve fcolumn(7)
'fcolumn(7) = Trim(Mid(str, 117, 9))
'
'ReDim Preserve fcolumn(8)
'fcolumn(8) = Trim(Mid(str, 126, 7))
'ReDim Preserve fcolumn(9)
'fcolumn(9) = Trim(Mid(str, 133, 7))
'fcolumn = Split(str, " ")
write_excel fcolumn
'MsgBox str
End If
Loop
cn1.Close
txt.Close
ProgressBar1.Value = 90
Set cn1 = Nothing
Set rs1 = Nothing
Set fs = Nothing
ProgressBar1.Value = 100
MsgBox "Report Completed - Please close this program and open Excel Report"
ProgressBar1.Visible = False
Cmd_Final_Msg.Visible = True
Cmd_Final_Msg.Caption = " Request Completed Successfully"
Cmd_Final_Msg.BackColor = vbGreen
End Function
Private Function write_excel(fvalues As Variant)
Dim strsheet As String
Dim i As Integer
Dim colcnt As Integer
For i = 0 To UBound(fvalues)
If i = 0 Then
If Trim(fvalues(i)) = "219" Or Trim(fvalues(i)) = "196" Or Trim(fvalues(i)) = "134" Then
strsheet = "Rerun Jobs$"
ElseIf Trim(fvalues(i)) = "0" Then
strsheet = "Others$"
Else
strsheet = "Failed Jobs$"
'Exit Function
End If
Exit For
End If
Next
' For i = 0 To UBound(fvalues)
' If i = 0 Then
' If Trim(fvalues(i)) = "1" Then
' strsheet = "sheet1$"
'
' End If
' Exit For
' End If
' Next
Set rs1 = New ADODB.Recordset
rs1.Open "select * from [" & strsheet & "] where 0=1", cn1, adOpenKeyset, adLockOptimistic
rs1.AddNew
colcnt = 0
For i = 0 To UBound(fvalues)
If Trim(fvalues(i)) <> "" Then
rs1.Fields(colcnt) = fvalues(i)
colcnt = colcnt + 1
End If
Next
rs1.Update
rs1.Close
Set rs1 = Nothing
End Function
|
the out put of excel sheet is not in order and is as follows
| Code: |
column1 column2 column3 cloumn4 column5 column5 column6
05/25/200 8 07:38:53 Server1 Client1 ent1 CLASS A 67
05/25/200 8 07:38:53 Server2 Client2 ent2 CLASS B 86
05/25/200 8 07:38:53 Server3 Client3 ent3 CLASS C 2
05/26/200 8 07:38:53 Server1 Client1 ent1 CLASS A 67
05/26/200 8 07:38:53 Server2 Client2 ent2 CLASS B 86
05/26/200 8 07:38:53 Server3 Client3 ent3 CLASS C 2
|
|
|
