Post by McKirahanPost by tdubbIts more like (b)
[snip]
Will this help?
This version will create a XLS file directly.
Option Explicit
'****
'* Read "cTXT" and write "cXLS".
'****
'*
'* Declare Constants
'*
Const cVBS = "tdubb123.vbs"
Const cTXT = "tdubb123.txt"
Const cXLS = "tdubb123.xls"
'*
'* Declare Globals
'*
Dim sDIR
sDIR = WScript.ScriptFullName
sDIR = Left(sDIR,InStrRev(sDIR,"\"))
'*
'* Declare Variables
'*
Dim str1ST
str1ST = ""
Dim arrCOL()
Dim intCOL
intCOL = 1
Dim strCOL
Dim arrDIC()
Dim intDIC
intDIC = 0
Dim strDIC
Dim intKOL
intKOL = 1
Dim arrOTF
Dim intOTF
Dim strOTF
Dim intPOS
Dim strRNG
Dim intROW
intROW = 2
Dim strTXT
Dim strVAL
'*
'* Declare Objects
'*
Dim objDIC
Set objDIC = CreateObject("Scripting.Dictionary")
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(sDIR & cXLS) Then
objFSO.DeleteFile(sDIR & cXLS)
End If
Dim objOTF
Dim objXLA
Set objXLA = CreateObject("Excel.Application")
objXLA.Visible = True
objXLA.Workbooks.Add
objXLA.Worksheets("Sheet1").PageSetup.LeftHeader = cXLS
objXLA.Worksheets("Sheet1").PageSetup.RightHeader = Now
objXLA.Worksheets("Sheet1").PageSetup.PrintTitleRows = "1:1"
objXLA.Worksheets("Sheet1").PageSetup.PrintGridlines = 1
'*
'* Read file
'*
Set objOTF = objFSO.OpenTextFile(sDIR & cTXT,1)
strOTF = objOTF.ReadAll
Set objOTF = Nothing
'*
'* Parse file
'*
arrOTF = Split(strOTF,vbCrLf)
For intOTF = 0 To UBound(arrOTF)
strTXT = arrOTF(intOTF)
If InStr(strTXT,vbTab) > 0 Then strTXT = Replace(strTXT,vbTab,"
")
If InStr(strTXT,Chr(34)) > 0 Then
MsgBox "Data contains quotation marks!",vbCritical,cVBS
Exit For
End If
intPOS = InStr(strTXT,": ")
If intPOS > 0 Then
'*
'* Split each valid line into name/value pair
'*
strDIC = Trim(Left(strTXT,intPOS-1))
strVAL = Trim(Mid(strTXT,intPOS+2))
'*
'* Identify first column name
'*
If str1ST = strDIC Then intROW = intROW + 1
If str1ST = "" Then str1ST = strDIC
'*
'* Test dictionary
'*
If Not objDIC.Exists(strDIC) Then
'*
'* Build dictionary of column names
'*
intDIC = intDIC + 1
objDIC.Add strDIC, intDIC
ReDim Preserve arrDIC(intDIC)
arrDIC(intDIC) = strDIC
'*
'* Write column header
'*
objXLA.Cells(1,intCOL).Value = strDIC
objXLA.Cells(intROW,intCOL).Value = strVAL
If intKOL < intCOL Then intKOL = intCOL
intCOL = intCOL + 1
Else
'*
'* Write column detail
'*
intCOL = CInt(objDIC.Item(strDIC))
objXLA.Cells(intROW,intCOL).Value = strVAL
End If
End If
Next
'*
'* Quit Excel
'*
strRNG = "A1:" & Chr(64+intKOL) & "1"
objXLA.Range(strRNG).Select
objXLA.Selection.Font.Bold = True
strRNG = "A1:" & Chr(64+intKOL) & intROW
objXLA.Range(strRNG).Select
objXLA.Selection.Font.Name = "Arial"
objXLA.Selection.Font.Size = 9
objXLA.Cells.EntireColumn.AutoFit
objXLA.ActiveWorkbook.SaveAs(sDIR & cXLS)
objXLA.Quit
'*
'* Destroy Objects
'*
Set objDIC = Nothing
Set objFSO = Nothing
Set objXLA = Nothing
'*
'* Finish Message
'*
MsgBox intROW & " rows.",vbInformation,cVBS