Откройте несколько текстовых файлов с выбранными данными в определенных столбцах, используя VBA

Question

Можете ли вы помочь мне с этим, я часами пытался понять это, но не смог. Примечание: я все еще изучаю VBA.

У меня есть 7 заголовков в одной электронной таблице, и я хочу перенести в них 7 текстовых файлов.

В каждом текстовом файле я хочу, чтобы 2 столбца в текстовом файле были выделены и помещены в правильный заголовок.

Я сделал этот бит, но хочу, чтобы все текстовые файлы открывались сразу в каждом заголовке. Моя проблема в том, что файлы изменяемы, поэтому я не хочу указывать имя файла, просто путь, и он выбирает самый старый текстовый файл даты в первом заголовке электронной таблицы.

Я попробовал Dir ("Y: \ Engineering \" & "* .txt"), но команда Open не работает, если путь не указан правильно, а копия текстового файла находится в папке с документами пользователя. Могу ли я исправить это, находясь только в пути без необходимости копировать в другую папку?

Заранее спасибо, я это очень ценю!

Вот что я сделал:

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

Обновленный код.

Функция Main () выполняет действия, также вы должны настроить эту часть: sPath = "C:\Tets\"

Условия: в файле Excel должны быть следующие листы - FileList, Import, ImportResults

Вы можете попробовать следующий код:

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