使用VBA在特定列中打开包含所选数据的多个文本文件

Question

May you please help me with this, I spent hours trying to figure it out but couldn't. Note: I am still learning VBA.

I have 7 headings in one spreadsheet that I want to transfer 7 text files into them.

In each text file, I want 2 columns in the text file to be selected and put into the correct heading.

I have got that bit done, but I want all text files to open at once at each heading. My problem is the files are changeable, so I don't want to specify the file name, just the path and it picks the oldest date text file to the first heading in the spreadsheet.

I tried Dir("Y:\\Engineering\\" & "*.txt") but Open command doesn't work, unless the path is correct and a copy of the text file is in the User Document Folder. Can I fix that to only being in the path without a need of a copy in a different folder?

Thanks in advance I appreciate it much!

This is what I have done:

Sub OpenText()
Dim FilePath As String
FilePath = "Y:\Engineering\1.txt"
Open FilePath For Input As #1 
row_number = 0
Do Until EOF(1)
Line Input #1 , LineFromFile
LineItems = Split(LineFromFile, ",")
ActiveCell.Offset(row_number, 0).Value = LineItems(1)
ActiveCell.Offset(row_number, 1).Value = LineItems(4)
row_number = row_number + 1
Loop
Close #1 
End Sub

Answer 1

Updated code.

Main() function does the actions, also you should setup this part: sPath = "C:\\Tets\\"

Conditions: you should have following sheets in excel file - FileList , Import , ImportResults

You can try following code:

Option Explicit

Public oFSO As Object
Public arrFiles()
Public lngFiles As Long
Sub Main()
    Dim sPath As String
    Dim strXlsList As String
    Dim strXlsListImport As String
    Dim strXlsListImportResults As String
    sPath = "C:\Tets\1\"
    strXlsList = "FileList"
    strXlsListImport = "Import"
    strXlsListImportResults = "ImportResults"
    Dim lngFilesCount As Long
    lngFilesCount = 0

    Erase arrFiles

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Call recurse(sPath)
    Dim Counter As Long

    For Counter = 0 To UBound(arrFiles, 2)
        Sheets(strXlsList).Range("A" & Counter + 1) = arrFiles(0, Counter)
        Sheets(strXlsList).Range("B" & Counter + 1) = arrFiles(1, Counter)
        lngFilesCount = lngFilesCount + 1
    Next Counter

    ' filter due date
    If ActiveSheet.Name <> strXlsList _
    Then
        Sheets(strXlsList).Activate
    End If
    Range("A2:B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("FileList").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("FileList").Sort.SortFields.Add Key:=Range("B2:B4") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("FileList").Sort
        .SetRange Range("A2:B4")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    Dim lngCurrent As Long
    Dim lngFilePositionColumn As Long
    Dim lngOffset As Long
    lngFilePositionColumn = 1
    lngOffset = 1
    For lngCurrent = 2 To lngFilesCount - 1
        ' import file
        ImportTextFile Sheets(strXlsList).Range("A" & lngCurrent), strXlsListImport

        ' copy data from 2nd column
        subCopyData strXlsListImport, strXlsListImportResults, 2, lngOffset
        lngOffset = lngOffset + 1
        ' copy data from 5th column
        subCopyData strXlsListImport, strXlsListImportResults, 5, lngOffset
        lngOffset = lngOffset + 1
    Next lngCurrent

End Sub

Public Sub subCopyData( _
                    ByVal strSheetFrom As String, _
                    ByVal strSheetTo As String, _
                    ByVal lngColumnNumberFrom As Long, _
                    ByVal lngOffset As Long)
    Sheets(strSheetFrom).Activate
    Columns(lngColumnNumberFrom).Select
    Selection.Copy
    Sheets(strSheetTo).Select
    Columns(lngOffset).Select
    ActiveSheet.Paste
End Sub
Sub recurse(sPath As String)
    Dim oFolder As Object
    Dim oSubFolder As Object
    Dim oFile As Object

    Set oFolder = oFSO.GetFolder(sPath)

    'Collect file information
    For Each oFile In oFolder.Files
        lngFiles = lngFiles + 1
        ReDim Preserve arrFiles(1, lngFiles + 1)
        arrFiles(0, lngFiles) = sPath & oFile.Name
        arrFiles(1, lngFiles) = oFile.DateLastModified
        Debug.Print lngFiles
    Next oFile

    'looking for all subfolders
    For Each oSubFolder In oFolder.SubFolders
    'recursive call is commented, looks only in folder
    'Call recurse(oSubFolder.Path)
    Next oSubFolder
End Sub
Sub ImportTextFile( _
                    ByVal strFile As String, _
                    ByVal strXlsList As String _
                    )
    If ActiveSheet.Name <> strXlsList _
    Then
        Sheets(strXlsList).Activate
    End If
    ' clear existing data
    Cells.Select
    Selection.Delete Shift:=xlUp
    ' import text file
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & strFile, _
        Destination:=Range("$A$1"))
        '.CommandType = 0
        .Name = "next"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 866
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub