Solved Mass Importing Txt Files (1 Viewer)

Number11

Member
Local time
Today, 09:17
Joined
Jan 29, 2020
Messages
616
I am looking for a better way to import txt files rather than me having to select the file and then import all the files are within 1 folder

Dim strFileName
Dim oExcel As Excel.Application
Dim oWb As Excel.Workbook
Set oExcel = CreateObject("Excel.Application")
Dim dlg As FileDialog
Set dlg = Application.FileDialog(msoFileDialogFilePicker)
Dim strFolderName As String
Dim strFolderExists As String


With dlg
.Title = "Select the Excel file to import"
.AllowMultiSelect = False
.Filters.Add "Text Files", "*.TXT", 1
.Filters.Add "All Files", "*.*", 2
.InitialFileName = "C:\importing\cash\"
If .Show = -1 Then
strFileName = .SelectedItems(1)

Dim content As String
Dim var As Variant
Dim path As String

'put the path and filename of textfile here
path = .SelectedItems(1)

With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(path, 1)
content = .ReadAll
.Close
End With
var = Split(content, vbCrLf)
For I = 1 To UBound(var)
var(I - 1) = var(I)
Next
ReDim Preserve var(UBound(var) - 1)
content = Join(var, vbCrLf)
With .OpenTextFile(path, 2)
.Write content
.Close
End With
End With

DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", strFileName, vbNo

Do Until IsNull(DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'"))
DoCmd.DeleteObject acTable, DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'")
Loop

Kill strFileName

End If
End With
 
I find it convincing if you put the files to be imported in a fixed, known folder. You can then go through this folder in a simple loop and import the files one after the other.
Code:
Sub DoIt()
    Dim sPath As String
    Dim sFile As String

    sPath = "C:\Testing\"             
    sFile = Dir(sPath & "TEST*.csv")                     
    Do While sFile > vbNullString         
        'Debug.Print sFile, sPath & sFile                         

        ' import / somehow use the file
    
        ' if necessary, delete the file (VBA.Kill) or move the file to an archive (VBA.Name)

        sFile = Dir                                 
    Loop
End Sub
The loop with Dir offers a pattern search so that selection can be made quite well.

Ideally, if I have a text file, I would link this file as a table and use an append query to transfer the information to the database table. Depending on the database schema, it might also be necessary to distribute the data across several tables with several queries.
 
Code:
    Dim strFileName
    Dim oExcel As Excel.Application
    Dim oWb As Excel.Workbook
    Set oExcel = CreateObject("Excel.Application")
    Dim strFolderName As String
    Dim strFolderExists As String

    Dim col As New Collection
    Dim j As Integer
    strFolderName = "C:\importing\cash\"
   
    strFileName = Dir$(strFolderName & "*.txt")
   
    Do Until Len(strFileName) = 0
        j = j + 1
        col.Add Item:=strFolderName & strFileName, Key:=j & ""
        strFileName = Dir$
    Loop
   
    For j = 1 To col.Count

            With CreateObject("Scripting.FileSystemObject")
                With .OpenTextFile(col(j & ""), 1)
                    content = .ReadAll
                    .Close
                End With
                var = Split(content, vbCrLf)
                For I = 1 To UBound(var)
                    var(I - 1) = var(I)
                Next
                ReDim Preserve var(UBound(var) - 1)
                content = Join(var, vbCrLf)
                With .OpenTextFile(col(j & ""), 2)
                    .Write content
                    .Close
                End With
            End With

            DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", col(j & ""), vbNo

            Do Until IsNull(DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'"))
                DoCmd.DeleteObject acTable, DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'")
            Loop

            Kill col(j & "")

    Next j
 
Code:
    Dim strFileName
    Dim oExcel As Excel.Application
    Dim oWb As Excel.Workbook
    Set oExcel = CreateObject("Excel.Application")
    Dim strFolderName As String
    Dim strFolderExists As String

    Dim col As New Collection
    Dim j As Integer
    strFolderName = "C:\importing\cash\"
  
    strFileName = Dir$(strFolderName & "*.txt")
  
    Do Until Len(strFileName) = 0
        j = j + 1
        col.Add Item:=strFolderName & strFileName, Key:=j & ""
        strFileName = Dir$
    Loop
  
    For j = 1 To col.Count

            With CreateObject("Scripting.FileSystemObject")
                With .OpenTextFile(col(j & ""), 1)
                    content = .ReadAll
                    .Close
                End With
                var = Split(content, vbCrLf)
                For I = 1 To UBound(var)
                    var(I - 1) = var(I)
                Next
                ReDim Preserve var(UBound(var) - 1)
                content = Join(var, vbCrLf)
                With .OpenTextFile(col(j & ""), 2)
                    .Write content
                    .Close
                End With
            End With

            DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", col(j & ""), vbNo

            Do Until IsNull(DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'"))
                DoCmd.DeleteObject acTable, DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'")
            Loop

            Kill col(j & "")

    Next j
Ok thank you for sharing, i am getting a run time error using this code..
1706695652112.png
 
maybe declare var As Variant?
Code:
    Dim strFileName
    Dim oExcel As Excel.Application
    Dim oWb As Excel.Workbook
    Set oExcel = CreateObject("Excel.Application")
    Dim strFolderName As String
    Dim strFolderExists As String

    Dim col As New Collection
    Dim j As Integer, i As Integer
    Dim var As Variant
    
    strFolderName = "C:\importing\cash\"
    
    strFileName = Dir$(strFolderName & "*.txt")
    
    Do Until Len(strFileName) = 0
        j = j + 1
        col.Add Item:=strFolderName & strFileName, Key:=j & ""
        strFileName = Dir$
    Loop
    
    For j = 1 To col.Count

            With CreateObject("Scripting.FileSystemObject")
                With .OpenTextFile(col(j & ""), 1)
                    content = .ReadAll
                    .Close
                End With
                var = Split(content, vbCrLf)
                For i = 1 To UBound(var)
                    var(i - 1) = var(i)
                Next
                ReDim Preserve var(UBound(var) - 1)
                content = Join(var, vbCrLf)
                With .OpenTextFile(path, 2)
                    .Write content
                    .Close
                End With
            End With

            DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", col(j & ""), vbNo

            Do Until IsNull(DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'"))
                DoCmd.DeleteObject acTable, DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'")
            Loop

            Kill col(j & "")

    Next j
 
DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", strFileName, vbNo True

Use the HasFieldNames argument and save yourself all the rearranging of content in the text files. The whole FSO block is unnecessary.

This is simpler and leaves no room for additional errors
 
maybe declare var As Variant?
Code:
    Dim strFileName
    Dim oExcel As Excel.Application
    Dim oWb As Excel.Workbook
    Set oExcel = CreateObject("Excel.Application")
    Dim strFolderName As String
    Dim strFolderExists As String

    Dim col As New Collection
    Dim j As Integer, i As Integer
    Dim var As Variant
   
    strFolderName = "C:\importing\cash\"
   
    strFileName = Dir$(strFolderName & "*.txt")
   
    Do Until Len(strFileName) = 0
        j = j + 1
        col.Add Item:=strFolderName & strFileName, Key:=j & ""
        strFileName = Dir$
    Loop
   
    For j = 1 To col.Count

            With CreateObject("Scripting.FileSystemObject")
                With .OpenTextFile(col(j & ""), 1)
                    content = .ReadAll
                    .Close
                End With
                var = Split(content, vbCrLf)
                For i = 1 To UBound(var)
                    var(i - 1) = var(i)
                Next
                ReDim Preserve var(UBound(var) - 1)
                content = Join(var, vbCrLf)
                With .OpenTextFile(path, 2)
                    .Write content
                    .Close
                End With
            End With

            DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", col(j & ""), vbNo

            Do Until IsNull(DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'"))
                DoCmd.DeleteObject acTable, DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'")
            Loop

            Kill col(j & "")

    Next j
Thanks added that getting another error now on

1706698437685.png


1706698456241.png
 
replace path with col(j & "")
 
replace path with col(j & "")
Thank you yes that worked, so now for a different question, i also have to import other text files they are in a folder and has then a folder for each day, folders are named as the date like this 2024-01-31 and contain 2-3 files in each folder how's best to get these to import in bulk too ?
 
put the foldername to a table, then you can use a Recordset to loop through the each folder:

tblFolders
Path (short text)

example:
Path
-------------------------------------------
C:\importing\cash\
C:\importing\2024-01-31\

using same code:
Code:
    Dim strFileName
    Dim oExcel As Excel.Application
    'Dim oWb As Excel.Workbook
    'Set oExcel = CreateObject("Excel.Application")
    Dim strFolderName As String
    Dim strFolderExists As String

    Dim col As New Collection
    Dim j As Integer, i As Integer
    Dim var As Variant
    Dim db As DAO.Database
    
    Set db = CurrentDb
    
    With db.OpenRecordset("tblFolders", dbOpenSnapshot, dbReadOnly)
        Do Until .EOF
        
            strFolderName = !path
    
            strFileName = Dir$(strFolderName & "*.txt")
    
            Do Until Len(strFileName) = 0
                j = j + 1
                col.Add Item:=strFolderName & strFileName, Key:=j & ""
                strFileName = Dir$
            Loop
    
            For j = 1 To col.Count

                With CreateObject("Scripting.FileSystemObject")
                    With .OpenTextFile(col(j & ""), 1)
                        content = .ReadAll
                        .Close
                    End With
                    var = Split(content, vbCrLf)
                    For i = 1 To UBound(var)
                        var(i - 1) = var(i)
                    Next
                    ReDim Preserve var(UBound(var) - 1)
                    content = Join(var, vbCrLf)
                    With .OpenTextFile(path, 2)
                        .Write content
                        .Close
                    End With
                End With

                DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", col(j & ""), vbNo

                Do Until IsNull(DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'"))
                    DoCmd.DeleteObject acTable, DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'")
                Loop

                Kill col(j & "")

            Next j
            .MoveNext
        Loop
        .Close
    End With
    Set db = Nothing
 
put the foldername to a table, then you can use a Recordset to loop through the each folder:

tblFolders
Path (short text)

example:
Path
-------------------------------------------
C:\importing\cash\
C:\importing\2024-01-31\

using same code:
Code:
    Dim strFileName
    Dim oExcel As Excel.Application
    'Dim oWb As Excel.Workbook
    'Set oExcel = CreateObject("Excel.Application")
    Dim strFolderName As String
    Dim strFolderExists As String

    Dim col As New Collection
    Dim j As Integer, i As Integer
    Dim var As Variant
    Dim db As DAO.Database
  
    Set db = CurrentDb
  
    With db.OpenRecordset("tblFolders", dbOpenSnapshot, dbReadOnly)
        Do Until .EOF
      
            strFolderName = !path
  
            strFileName = Dir$(strFolderName & "*.txt")
  
            Do Until Len(strFileName) = 0
                j = j + 1
                col.Add Item:=strFolderName & strFileName, Key:=j & ""
                strFileName = Dir$
            Loop
  
            For j = 1 To col.Count

                With CreateObject("Scripting.FileSystemObject")
                    With .OpenTextFile(col(j & ""), 1)
                        content = .ReadAll
                        .Close
                    End With
                    var = Split(content, vbCrLf)
                    For i = 1 To UBound(var)
                        var(i - 1) = var(i)
                    Next
                    ReDim Preserve var(UBound(var) - 1)
                    content = Join(var, vbCrLf)
                    With .OpenTextFile(path, 2)
                        .Write content
                        .Close
                    End With
                End With

                DoCmd.TransferText acImportFixed, "Cash Import Specification", "Cash_Importing", col(j & ""), vbNo

                Do Until IsNull(DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'"))
                    DoCmd.DeleteObject acTable, DLookup("Name", "Msysobjects", "Name like '*ImportErrors*'")
                Loop

                Kill col(j & "")

            Next j
            .MoveNext
        Loop
        .Close
    End With
    Set db = Nothing
setup the table as you have suggested and started the job it imported all the files within the first folder and deleted them as planned and it threw up this error...

1706710908077.png


1706710935379.png


if i now try to start the job again its says..
1706711431336.png

1706710935379.png
 
Last edited:
sorry, you need to reset the Collection object again.
add this, line like this:

Code:
...
...
      .MoveNext
      Set col = New Collection
      j = 0
  Loop
  .Close
End With
set db = Nothing
 
sorry, you need to reset the Collection object again.
add this, line like this:

Code:
...
...
      .MoveNext
      Set col = New Collection
      j = 0
  Loop
  .Close
End With
set db = Nothing
thanks also had to change

With .OpenTextFile(path, 2)
to

With .OpenTextFile(col(j & ""), 2)

running now...
 
I am looking for a better way to import txt files rather than me having
Just shyly asked back:
A massive code shortening and simplification plus acceleration of the overall process see #6 probably doesn't play a role in this search?
 

Users who are viewing this thread

Back
Top Bottom