Solved Converting txt file to xlsx

M

miacino

Registered User.
Local time
Today, 07:06
Joined
Jun 5, 2007
Messages
106
I'm trying to take all txt files in a folder and convert them to excel files. I 'borrowed' the below code and it seems to work EXCEPT that it only does text to columns on the header line. (Be gentle - I so appreciate all your expertise, but I'm really not great at this... Any help is appreciated!)
Code: 
Private Sub Command108_Click()
    Dim sDir As String
    Dim objXl As Object
    Dim objWB As Object
    Dim objSH As Object
    Const xlDelimited As Integer = 1
    Const xlDoubleQuote As Integer = 1
    Const xlOpenXMLWorkbook As Integer = 51
    
    sPath = "G:\CCCN\Payer Relations-Contracting\Payer Data Files\Anthem\test convert\"
    Set objXl = CreateObject("Excel.Application")
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    sDir = Dir$(sPath & "*.txt", vbNormal)
    Do Until Len(sDir) = 0
        Set objWB = objXl.Workbooks.Open(sPath & sDir)
        Set objSH = objWB.sheets(1)
        With objSH
            objXl.Selection.TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                :="|", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
        End With
        objWB.SaveAs FileName:=Left(objWB.FullName, InStrRev(objWB.FullName, ".")) & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        objWB.Close False
        Set objSH = Nothing
        Set objWB = Nothing
        sDir = Dir$
    Loop
    objXl.Quit
    Set objXl = Nothing

End Sub
 
Why not record a macro in Excel that brings in a text file.
Then adapt that for your multiple files?
 
just did this macro to import a pipe delimited file.

Works OK for me - suggest compare with your code - I can see a number of differences in property names

Code: 
Sub Macro1()
'
' Macro1 Macro
'
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;D:\Dev\1_temp\test.txt", _
        Destination:=Range("$A$1"))
        .Name = "test"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "|"
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With


End Sub

Note this code does not include saving as .xlsx
 
you may also try this:
Code: 
Private Sub Command108_Click()
    Dim sDir As String
    Dim sPath As String
    
    sPath = "G:\CCCN\Payer Relations-Contracting\Payer Data Files\Anthem\test convert\"
    sDir = Dir$(sPath & "*.txt", vbNormal)
    Do Until Len(sDir) = 0
        Call fnConvertTextFileToExcel(sPath & sDir)
        sDir = Dir$
    Loop
End Sub

Sub fnConvertTextFileToExcel(ByVal TextFile As String)
    Const xlOpenXMLWorkbook As Integer = 51
    Dim fso                 As Object
    Dim inputFile           As Object
    Dim excelApp            As Object
    Dim excelWorkbook       As Object
    Dim excelWorksheet      As Object
    Dim lineText            As String
    Dim dataArray()         As String
    Dim rowIndex            As Long
    Dim colIndex            As Long

    ' Create FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Specify the path to your text file
    Set inputFile = fso.OpenTextFile(TextFile, 1)
    
    ' Create new instance of Excel application
    Set excelApp = CreateObject("Excel.Application")
    'excelApp.Visible = True
    
    ' Create new workbook
    Set excelWorkbook = excelApp.Workbooks.Add
    Set excelWorksheet = excelWorkbook.sheets(1)
    
    ' Read text file line by line and write to Excel
    rowIndex = 1
    Do While Not inputFile.AtEndOfStream
        lineText = inputFile.ReadLine
        dataArray = Split(lineText, ",") ' Assuming CSV format, change delimiter as needed
        
        ' Write data to Excel
        For colIndex = LBound(dataArray) To UBound(dataArray)
            excelWorksheet.Cells(rowIndex, colIndex + 1).Value = dataArray(colIndex)
        Next colIndex
        
        rowIndex = rowIndex + 1
    Loop
    
    ' Close and clean up
    inputFile.Close
    Set inputFile = Nothing
    Set fso = Nothing
    Set excelWorksheet = Nothing
    excelWorkbook.SaveAs _
                FileName:=fnGetPath(TextFile) & Replace$(fnGetFileName(TextFile), ".txt", ".xlsx"), _
                FileFormat:=xlOpenXMLWorkbook, _
                CreateBackup:=False
    excelWorkbook.Close
    Set excelWorkbook = Nothing
    excelApp.Quit
    Set excelApp = Nothing

End Sub

Public Function fnGetFileName(ByVal Path As String) As String
    Dim i As Integer
    fnGetFileName = Path
    i = InStrRev(Path, "\")
    If i <> 0 Then
        fnGetFileName = Mid$(Path, i + 1)
    End If
End Function


Public Function fnGetPath(ByVal FileName As String) As String
    Dim i As Integer
    fnGetPath = FileName
    i = InStrRev(FileName, "\")
    If i <> 0 Then
        fnGetPath = Left$(FileName, i)
    End If
End Function
 
Before importing or converting, I would first look at the content of the text files themselves.
Any code to be applied must take into account the content that can be found, and if the content does not meet expected standards, standard processing methods will also fail.

So take a look at what you have before you start juggling codes.
 
arnelgp said:
you may also try this:
Code: 
Private Sub Command108_Click()
    Dim sDir As String
    Dim sPath As String
   
    sPath = "G:\CCCN\Payer Relations-Contracting\Payer Data Files\Anthem\test convert\"
    sDir = Dir$(sPath & "*.txt", vbNormal)
    Do Until Len(sDir) = 0
        Call fnConvertTextFileToExcel(sPath & sDir)
        sDir = Dir$
    Loop
End Sub

Sub fnConvertTextFileToExcel(ByVal TextFile As String)
    Const xlOpenXMLWorkbook As Integer = 51
    Dim fso                 As Object
    Dim inputFile           As Object
    Dim excelApp            As Object
    Dim excelWorkbook       As Object
    Dim excelWorksheet      As Object
    Dim lineText            As String
    Dim dataArray()         As String
    Dim rowIndex            As Long
    Dim colIndex            As Long

    ' Create FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    ' Specify the path to your text file
    Set inputFile = fso.OpenTextFile(TextFile, 1)
   
    ' Create new instance of Excel application
    Set excelApp = CreateObject("Excel.Application")
    'excelApp.Visible = True
   
    ' Create new workbook
    Set excelWorkbook = excelApp.Workbooks.Add
    Set excelWorksheet = excelWorkbook.sheets(1)
   
    ' Read text file line by line and write to Excel
    rowIndex = 1
    Do While Not inputFile.AtEndOfStream
        lineText = inputFile.ReadLine
        dataArray = Split(lineText, ",") ' Assuming CSV format, change delimiter as needed
       
        ' Write data to Excel
        For colIndex = LBound(dataArray) To UBound(dataArray)
            excelWorksheet.Cells(rowIndex, colIndex + 1).Value = dataArray(colIndex)
        Next colIndex
       
        rowIndex = rowIndex + 1
    Loop
   
    ' Close and clean up
    inputFile.Close
    Set inputFile = Nothing
    Set fso = Nothing
    Set excelWorksheet = Nothing
    excelWorkbook.SaveAs _
                FileName:=fnGetPath(TextFile) & Replace$(fnGetFileName(TextFile), ".txt", ".xlsx"), _
                FileFormat:=xlOpenXMLWorkbook, _
                CreateBackup:=False
    excelWorkbook.Close
    Set excelWorkbook = Nothing
    excelApp.Quit
    Set excelApp = Nothing

End Sub

Public Function fnGetFileName(ByVal Path As String) As String
    Dim i As Integer
    fnGetFileName = Path
    i = InStrRev(Path, "\")
    If i <> 0 Then
        fnGetFileName = Mid$(Path, i + 1)
    End If
End Function


Public Function fnGetPath(ByVal FileName As String) As String
    Dim i As Integer
    fnGetPath = FileName
    i = InStrRev(FileName, "\")
    If i <> 0 Then
        fnGetPath = Left$(FileName, i)
    End If
End Function
Click to expand...


Thank you , thank you arnelgp! That worked absolutely perfectly!
 
You must log in or register to reply here.

Similar threads

K
Import csv to excel to access table
Replies
11
Views
358
ebs17
E
N
Solved Mass Importing Txt Files
Replies
14
Views
797
ebs17
E
J
Copy URL file to local folder
Replies
5
Views
202
JohnPapa
J
P
Solved Access VBA
Replies
4
Views
350
prasadgov
P
W
CSV or XLSX Bank Statement to Access module (need to import via VBA and then write back to Excel with imported flag)
Replies
14
Views
1,510
Cotswold
Cotswold

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom