VBA для импорта 10 последних созданных текстовых файлов в Excel

Question

В настоящее время у меня есть код VBA, который открывает каждый текстовый файл в заданном месте и импортирует данные в Excel. Проблема в том, что у меня есть 1000 текстовых файлов в этом месте, и я не хочу импортировать их все. Я хочу импортировать только 10 последних созданных текстовых файлов. Как я могу изменить свой Do Пока l oop, чтобы достичь этого?

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 LastCol As Long
Dim RowCount As Long

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

Sheets("26").Select
Cells.Select
Selection.ClearContents
Range("A1").Select

' Defines LastCol as the last column of data based on row 1
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

' Sets the folder containing the text files
myPath = "C:\26" & "\"

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

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

' Loop through each text file in folder
Do While myFile <> ""
    ' Sets variable "RowCount" To 1
    RowCount = 1
    ' Sets variable "Text" as blank
    Text = ""
    ' Set variable equal to opened text file
    Open myPath & myFile For Input As #1
    ' 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 RowCount row of the current last column with the content of variable "Text"
        Cells(RowCount, LastCol).Value = Text
        ' Increase RowCount by 1
        RowCount = RowCount + 1
    Loop

    ' Close the text file
    Close #1

    ' Increase LastCol by 1 to account for the new data
    LastCol = LastCol + 1

    ' Get next text file name
    myFile = Dir
Loop

Answer 1

Решение, которое сработало для меня в итоге, заключалось в следующем. В частности, строка «test = FileDateTime (myPath & myFile)» сделала мой трюк. Затем я записал результат обратно в верхний ряд столбца, в который извлекались данные.

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 LastCol As Long
Dim RowCount As Long

Dim test As Date
Dim fso As Object

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

Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents
Range("A1").Select

' Defines LastCol as the last column of data based on row 1
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

' Sets the folder containing the text files
myPath = "\\YourLocation" & "\"

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

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


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

    ' 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 RowCount row of the current last column with the content of variable "Text"
        Cells(RowCount, LastCol).Value = Text
        ' Increase RowCount by 1
        RowCount = RowCount + 1
    Loop
        Set fso = CreateObject("Scripting.FileSystemObject")
        test = FileDateTime(myPath & myFile)
        Cells([1], LastCol).Value = test

    ' Close the text file
    Close #1

    ' Increase LastCol by 1 to account for the new data
    LastCol = LastCol + 1

    ' Get next text file name
    myFile = Dir
Loop

Answer 2

Пожалуйста, попробуйте этот подход. В верхней части кода есть две константы, которые вам может потребоваться настроить. TopCount представляет количество файлов, имена которых вы хотите. В вашем вопросе это 10, но в коде вы можете ввести любое число. TmpTab - это имя рабочей таблицы, которую код создаст в ActiveWorkbook. Обратите особое внимание на это слово: ActiveWorkbook - это книга, которую вы в последний раз просматривали до запуска кода. Это не обязательно должна быть рабочая книга, содержащая код. В любом случае код создаст рабочий лист с именем, заданным константой `TmpTab ', использует его для сортировки и затем удалит его. Если это имя существующего рабочего листа, он будет очищен, использован и удален.

Function TenLatest() As String()

Const TopCount As Long = 10                 ' change to meet requirement
Const TmpTab As String = "Sorter"

Dim Fun() As String                         ' function return value
Dim SourceFolder As String
Dim Fn As String                            ' File name
Dim Arr() As Variant
Dim Ws As Worksheet
Dim Rng As Range
Dim i As Long

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then                      ' if OK is pressed
        SourceFolder = .SelectedItems(1)
    End If
End With

If SourceFolder <> "" Then                  ' a folder was chosen
    ReDim Arr(1 To 2, 1 To 10000)           ' increase if necessary
    Fn = Dir(SourceFolder & "\*.TXT")       ' change the filter "TXT" if necessary
    Do While Len(Fn) > 0
        i = i + 1
        Arr(1, i) = SourceFolder & "\" & Fn
        Arr(2, i) = FileDateTime(Arr(1, i))
        Fn = Dir
    Loop

    If i < 1 Then i = 1
    ReDim Preserve Arr(1 To 2, 1 To i)
    Application.ScreenUpdating = False
    On Error Resume Next
    Set Ws = Worksheets(TmpTab)
    If Err Then
        Set Ws = Worksheets.Add
        Ws.Name = TmpTab
    End If
    With Ws
        .Cells.ClearContents
        Set Rng = .Cells(1, 1).Resize(UBound(Arr, 2), UBound(Arr, 1))
        Rng.Value = Application.Transpose(Arr)

        With .Sort.SortFields
        .Clear
        .Add Key:=Rng.Columns(2), _
             SortOn:=xlSortOnValues, _
             Order:=xlDescending, _
             DataOption:=xlSortNormal
        End With
        With .Sort
            .SetRange Rng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

    With Rng.Columns(1)
        i = Application.WorksheetFunction.Min(.Rows.Count, TopCount)
        Arr = .Range(.Cells(1), .Cells(i)).Value
    End With

    ReDim Fun(1 To UBound(Arr))
    For i = 1 To UBound(Fun)
        Fun(i) = Arr(i, 1)
    Next i
    TenLatest = Fun


    With Application
        .DisplayAlerts = False
        Ws.Delete
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End If

End Function

Приведенный выше код возвращает массив (10) имен файлов, которые вы можете использовать любым подходящим для вас способом. Для проверки функции, пожалуйста, используйте процедуру ниже. Он вызовет функцию и запишет свой результат в «Немедленное окно».

Private Sub TestTenLatest()

Dim Fun() As String
Dim i As Integer

Fun = TenLatest
For i = 1 To UBound(Fun)
    Debug.Print i, Fun(i)
Next i

End Sub