VBA Convert excel document to text file

[cob2020]

Hi all,
I have to implement a requirement on a small project. I have searched online and even attempted to record a macro, but the samples I found were created for slightly different purposes.

Without beating around the bush, let me briefly describe what users do and what the vba script is expected to do:

1. Users download an excel template. The template has 3 worksheets. Users add information on the 3rd worksheet named 'Product Data'. There are no tables
2. The completed excel template is saved in the C:/Download directory (the file can be named whatever by the user and they have been instructed that the directory should only have one excel file at a time. The extension ends in .xlsx)
3. From a button in an access database, I want a vba script to determine the presence of an excel file and then convert the 3rd worksheet ('Product Data') of the excel template into a text file (tab delimited) and the name should be 'vendor.txt'.
4. The text file should be created in the same C:/Download directory and if there is currently a text file with the same name, I want it overwritten.

That is basically all there is to it. I sincerely hope one of the pros in this forum can help.

 

[Trebor76]

Hi cob2020,

It's been a while since I've programmed into Access but this seems to do the job:

Option Compare Database
Option Explicit
Sub CreateTextFile()

    'https://www.mrexcel.com/board/threads/vba-convert-excel-document-to-text-file.1203039

    Dim strPath As String, strExcelFile As String
    Dim objExcelApp As Object, objExcelWB As Object, objExcelWS As Object
    Dim varExcelCellValue As Variant
    Dim intTextFile
    Dim i As Long, j As Long
    
    strPath = "C:\Download"
    strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
    strExcelFile = FileName(strPath)
    If Len(strExcelFile) = 0 Then
        MsgBox "There is no *.xlsx Excel file in """ & strPath & """." & vbNewLine & "Please check and try again.", vbExclamation
        Exit Sub
    End If
    
    Set objExcelApp = CreateObject("Excel.Application")
    objExcelApp.Visible = True
    Set objExcelWB = objExcelApp.Workbooks.Open(strPath & strExcelFile)
    Set objExcelWS = objExcelWB.Sheets("Product Data")
    
    intTextFile = FreeFile
    Open strPath & "Vendor.txt" For Output As #intTextFile
    
    With objExcelWS
        For i = 1 To .cells.Find("*", SearchOrder:=1, SearchDirection:=2).Row '1 = xlByRows, 2 = xlPrevious
            For j = 1 To .cells.Find("*", SearchOrder:=2, SearchDirection:=2).Column '2 = xlByColumns, 2 = xlPrevious
                varExcelCellValue = IIf(Len(varExcelCellValue) = 0, .cells(i, j), varExcelCellValue & vbTab & .cells(i, j))
            Next j
            Print #intTextFile, varExcelCellValue
            varExcelCellValue = Empty
        Next i
    End With
    
    Close #intTextFile
    
    objExcelWB.Close
    objExcelApp.Quit
    Set objExcelWB = Nothing
    Set objExcelApp = Nothing
    
    MsgBox "Text file has now been created ready for review.", vbInformation

End Sub
Function FileName(strPath As String) As String

On Error GoTo ErrTrap

    Dim strFileName As String
    
    strFileName = Dir(strPath)

    Do Until Len(strFileName) = 0
        If StrConv(Left(Right(strFileName, Len(strFileName) - InStrRev(strFileName, ".")), 4), vbLowerCase) = "xlsx" Then
            FileName = strFileName
            Exit Function
        End If
        strFileName = Dir
    Loop
    
Exit Function

ErrTrap:

    strFileName = ""

End Function

Regards,

Robert

 

[cob2020]

Wow Trebor... beautifully done. Thanks so much. I appreciate it.

 

[Trebor76]

Thanks for letting us know and you're welcome