Importing Multiple .Txt Files Into Excel Based on the Date Last Modified (VBA)

[thelukeee]

Hello everyone,
I'd appreciate some coding help in Excel using VBA.

Background: There is a new .txt file made for each furnace run. The .txt file is created automatically in the system, and goes unedited by anyone, therefore using the date last modified is a viable way to sort through the files.

Goal of project:
1. The purpose of this code is the pull all of the files located the file name myPath="_____".
2. List out all the lines in the .txt files in seperate columns (a new row is created after each text file)
3. The goal is to be able to only pull files that have a 'lastModifiedDate' that are within a desired range (between 'Start Date' and 'End Date')
This is the purpose of the If statement. The contents of the .txt file should be saved in its unique role, seperated into columns. If the 'lastDateModified' is outside the range,
as applied in the Else statement, then it moves to the next .txt file.

Error: "Run-time error '55': File already open.

Note: I had success with the code without the date criteria. Everything was the same with the code except for the for and else loop. I'm assuming there is some sort of problem with the 'Close #1' statements but I am unsure...
The data in excel shows what I got from the text files without the date criteria. It takes a very long time to load ALL of the text files about (17,000 files spanning from 10 years ago). I want to be able to update my excel file possibly on a daily basis to import the new .txt files that are being created.

Thank you very much for any help.


Code:

Sub LoopThroughTextFiles()
' Defines variables
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Text As String
Dim Textline As String
Dim lastrow As Long
Dim colcount As Long


' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False


' Defines lastrow as the last column of data based on row 1
lastrow = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
' Sets the folder containing the text files
myPath = "\\hsmpcs01\HCTMFG\FURNACE\AtmFurnace\Run Reports" & "\"


' Target File Extension (must include wildcard "*")
myExtension = "*.txt"


' Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

StartDate = Worksheets("Intro").Range("B5")
EndDate = Worksheets("Intro").Range("B6")


' Loop through each text file in folder
Do While myFile <> ""
' Sets variable "colcount" To 1
colcount = 1
' Sets variable "Text" as blank
Text = ""
' Set variable equal to opened text file
Open myPath & myFile For Input As #1

lastModifiedDate = FileDateTime(myFile)

If lastModifiedDate >= StartDate And lastModifiedDate <= EndDate Then
' Do until the last line of the text file
Do Until EOF(1)
' Add each line of the text file to variable "Text"
Line Input #1, Textline
Text = Textline
' Update colcount row of the current last column with the content of variable "Text"
Cells(lastrow, colcount).Value = Text
' Increase colcount by 1
colcount = colcount + 1
Loop
' Close the text file
Close #1
' Increase lastrow by 1 to account for the new data
lastrow = lastrow + 1
' Get next text file name
myFile = Dir
Else
Close #1
End If
Loop


ResetSettings:
' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.ScreenUpdating = True

' Message Box when tasks are completed
MsgBox "Task Complete!"


End Sub



Picture 1: .txt files that are being imported

Picture 2: Example of one of the .txt files

Picture 3: All of the .txt files that were successfully imported to my excel file, but it took a long time and makes the file lag. I don't care about data from many years ago. I want to be able to only pull .txt files based on the date the
file was last modified.

 

[John_w]

Welcome to MrExcel forums.

Error: "Run-time error '55': File already open.

Note: I had success with the code without the date criteria. Everything was the same with the code except for the for and else loop. I'm assuming there is some sort of problem with the 'Close #1' statements but I am unsure...

The lack of indentation makes it difficult to follow your code and tell the reason for that error. Please use VBA code tags when posting code - click the VBA icon in the message toolbar.

If you put the Open statement inside the If statement then only one Close is needed. Also, lastModifiedDate = FileDateTime(myFile) should be lastModifiedDate = FileDateTime(myPath & myFile)

Try this macro instead.

Public Sub Import_Text_Files()

    Dim destBaseCell As Range, r As Long
    Dim textFilesFolder As String
    Dim startDate As Date, endDate As Date
    Dim FSO As Object, FSfile As Object, ts As Object
    Dim lines As Variant
 
    textFilesFolder = "\\hsmpcs01\HCTMFG\FURNACE\AtmFurnace\Run Reports\"
 
    startDate = Worksheets("Intro").Range("B5").Value
    endDate = Worksheets("Intro").Range("B6").Value
 
    With ActiveSheet
        Set destBaseCell = .Cells(.Rows.Count, "A").End(xlUp)
        If destBaseCell.Row > 1 Then Set destBaseCell = destBaseCell.Offset(1)
    End With
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    r = 0
    For Each FSfile In FSO.GetFolder(textFilesFolder).Files
        If LCase(FSfile.Name) Like LCase("*.txt") And FSfile.DateLastModified >= startDate And FSfile.DateLastModified <= endDate Then
            Set ts = FSfile.OpenAsTextStream
            lines = Split(ts.ReadAll, vbCrLf)
            ts.Close
            destBaseCell.Offset(r).Resize(1, UBound(lines) + 1).Value = lines
            r = r + 1
        End If
    Next
 
    Application.ScreenUpdating = True
    Application.EnableEvents = True
 
    MsgBox "Done"

End Sub

 

[thelukeee]

Okay-I'll give that a try.

Sorry about that. Here is my code from my original post in the right format:

Sub LoopThroughTextFiles()
' Defines variables
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Text As String
Dim Textline As String
Dim lastrow As Long
Dim colcount As Long


' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False


' Defines lastrow as the last column of data based on row 1
lastrow = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
' Sets the folder containing the text files
myPath = "\\hsmpcs01\HCTMFG\FURNACE\AtmFurnace\Run Reports" & "\"


' Target File Extension (must include wildcard "*")
myExtension = "*.txt"


' Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

StartDate = Worksheets("Intro").Range("B5")
EndDate = Worksheets("Intro").Range("B6")


' Loop through each text file in folder
Do While myFile <> ""
    ' Sets variable "colcount" To 1
    colcount = 1
    ' Sets variable "Text" as blank
    Text = ""
    ' Set variable equal to opened text file
    Open myPath & myFile For Input As #1

    lastModifiedDate = FileDateTime(myFile)
    
    If lastModifiedDate >= StartDate And lastModifiedDate <= EndDate Then
        ' Do until the last line of the text file
        Do Until EOF(1)
            ' Add each line of the text file to variable "Text"
            Line Input #1, Textline
            Text = Textline
            ' Update colcount row of the current last column with the content of variable "Text"
            Cells(lastrow, colcount).Value = Text
            ' Increase colcount by 1
            colcount = colcount + 1
        Loop
        ' Close the text file
        Close #1
        ' Increase lastrow by 1 to account for the new data
        lastrow = lastrow + 1
        ' Get next text file name
        myFile = Dir
    Else
        Close #1
    End If
Loop


ResetSettings:
' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.ScreenUpdating = True

' Message Box when tasks are completed
MsgBox "Task Complete!"


End Sub

 

[Fluff]

Cross posted multiple sites.
While we do allow Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules). This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered elsewhere.

Please supply links to all other sites where you have asked this question.
Thanks

 

[thelukeee]

This question was posted on 4 different sites:

Oz Grid: Importing Multiple .Txt Files Into Excel Based on the Date Last Modified in VBA (NEW) - OzGrid Free Excel/VBA Help Forum
-No response (09/22/20)

VBAexpress: Importing Multiple .Txt Files Into Excel Based on the Date Last Modified in VBA
-No response (09/22/20)

MrExcel: Importing Multiple .Txt Files Into Excel Based on the Date Last Modified (VBA)
-Response by John_W provided code that works but no correction to my code (09/09/20)

Excel Forum: Importing Multiple .Txt Files Into Excel Based on the Date Last Modified (VBA)
-No response (09/22/20)

 

[thelukeee]

Welcome to MrExcel forums.
The lack of indentation makes it difficult to follow your code and tell the reason for that error. Please use VBA code tags when posting code - click the VBA icon in the message toolbar.

If you put the Open statement inside the If statement then only one Close is needed. Also, lastModifiedDate = FileDateTime(myFile) should be lastModifiedDate = FileDateTime(myPath & myFile)

Try this macro instead.

Public Sub Import_Text_Files()

    Dim destBaseCell As Range, r As Long
    Dim textFilesFolder As String
    Dim startDate As Date, endDate As Date
    Dim FSO As Object, FSfile As Object, ts As Object
    Dim lines As Variant

    textFilesFolder = "\\hsmpcs01\HCTMFG\FURNACE\AtmFurnace\Run Reports\"

    startDate = Worksheets("Intro").Range("B5").Value
    endDate = Worksheets("Intro").Range("B6").Value

    With ActiveSheet
        Set destBaseCell = .Cells(.Rows.Count, "A").End(xlUp)
        If destBaseCell.Row > 1 Then Set destBaseCell = destBaseCell.Offset(1)
    End With

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    r = 0
    For Each FSfile In FSO.GetFolder(textFilesFolder).Files
        If LCase(FSfile.Name) Like LCase("*.txt") And FSfile.DateLastModified >= startDate And FSfile.DateLastModified <= endDate Then
            Set ts = FSfile.OpenAsTextStream
            lines = Split(ts.ReadAll, vbCrLf)
            ts.Close
            destBaseCell.Offset(r).Resize(1, UBound(lines) + 1).Value = lines
            r = r + 1
        End If
    Next

    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MsgBox "Done"

End Sub

You're a wizard. I don't understand how you did this.