Скажите VBA использовать самый последний файл в соответствии с шаблоном имени файла

У меня есть папка с множеством разных файлов Excel, сохраненных в следующем формате:

  • 2018.01 final.xlsx
  • 2018.02 final.xlsx
  • 2018.03 final xlsx.
  • так далее...

Я хотел бы выполнить VLOOKUP на самом последнем файле в соответствии с шаблоном имени файла. Сегодня было бы 2018.08 final xlsx,

  • Если августовский файл еще не сохранен, я хотел бы использовать предыдущий месяц, т.е. июль (2018.07 final.xlsx).

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

Любая идея, как я могу сделать это в VBA? Спасибо за помощь ребята

  fromPath = Sheets("Open latest file").Range("B5")
  fromPath2 = Sheets("Open latest file").Range("B6")

  If Dir(fromPath) = "" Then

    Workbooks.Open (fromPath2)

  Else

    Workbooks.Open (fromPath)

  End If

End Sub
Источник

4 ответа

Решение

К счастью для вас, у меня уже есть функция, которую я люблю использовать, которая по сути делает то, что вы ищете:

Function GetMostRecentExcelFile(ByVal myDirectory As String, ByVal filePattern As String) As String

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim myFolder As Object
    Set myFolder = fso.getfolder(IIf(Right(myDirectory, 1) = "\", myDirectory, myDirectory & "\"))

    Dim currentDate As Date
    Dim fname As String

    Dim currentFile As Object
    For Each currentFile In myFolder.Files
        If (currentDate = CDate(0) Or currentFile.DateCreated > currentDate) And currentFile.name Like filePattern _
            And InStr(LCase$(currentFile.name), ".xlsx") > 0 And InStr(currentFile.name, "~$") = 0 Then

            currentDate = currentFile.DateCreated
            fname = currentFile.name

        End If
    Next currentFile

    GetMostRecentExcelFile = fname

End Function

Это будет цикл через указанный myDirectory ищет любые файлы, которые соответствуют filePattern что вы дадите и вернете файл с последним созданным файлом, который соответствует указанному шаблону.

Примечание: он не выбирает файл на основе имени файла, только на основе файла CreationDate !!

Вот как вы, скорее всего, использовали бы его для решения своей проблемы:

Sub Main()

    Dim pattern As String
    pattern = "*20##.## final*"

    Dim path As String
    path = sheets("Open latest file").Range("B5").Value2

    Dim filename As String
    filename = GetMostRecentExcelFile(path, pattern)

    If Len(filename) = 0 Or Len(Dir(filename)) = 0 Then
        path = sheets("Open latest file").Range("B6").Value2
        filename = GetMostRecentExcelFile(path, pattern)
    End If

    If Len(filename) > 0 Then
        Workbooks.Open (IIf(Right(path, 1) = "\", path, path & "\") & filename)
    Else
        MsgBox "No files found matching pattern"
    End If

End Sub
Источник

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

Option Explicit
Public Sub GetLastestFile()
    Const PATH As String = "C:\Users\User\Desktop\Testing"
    Dim fso As Object, oFolder As Object, oFile As Object, list As Object, tempString As String
    Set list = CreateObject("System.Collections.SortedList")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(PATH)

    For Each oFile In oFolder.Files
        If IsFound(oFile.Name) Then
            tempString = Replace$(Left$(oFile.Name, 7), ".", vbNullString)
            With list
                If Not .contains(tempString) Then
                    .Add tempString, vbNullString
                End If
            End With
        End If
    Next
     Debug.Print list.Getkey(list.Count - 1)
End Sub
Public Function IsFound(ByVal inputString As String) As Boolean
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\d{4}.\d{2}\sfinal.xlsx"
        IsFound = .test(inputString) 
    End With
End Function

Вы можете попробовать регулярное выражение здесь.

Regex

Regex объяснение:

\ Д {4}.\ Д {2} \sfinal.xlsx

\ d {4} соответствует цифре (равно [0-9]) {4} Квантификатор - соответствует ровно 4 раза

, соответствует любому символу (кроме ограничителей строки)

\ d {2} соответствует цифре (равно [0-9]) {2} Квантификатор - соответствует ровно 2 раза

\s соответствует любому символу пробела (равен [\ r \ n \ t \ f \ v])

final соответствует буквам символов final (с учетом регистра) . соответствует любому символу (кроме ограничителей строки) xlsx соответствует буквально символам xlsx (с учетом регистра)

Используя класс

Еще лучше было бы реализовать класс для регулярного выражения, который имеет метод IsFound, Это позволит избежать постоянного создания и уничтожения объекта регулярных выражений. Вместо этого он будет создан с использованием экземпляра класса, а затем только методом, вызываемым как требуется.

Если вы создаете класс с именем RegexFileMatch затем введите следующий код:

Option Explicit
Private re As Object
Private Sub Class_Initialize()
    Set re = CreateObject("VBScript.RegExp")
End Sub

Public Function IsFound(ByVal inputString As String) As Boolean
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\d{4}.\d{2}\sfinal.xlsx"
        IsFound = .test(inputString)
    End With
End Function

Затем измените код вызова в стандартном модуле на:

Option Explicit
Public Sub GetLastestFile()
    Const PATH As String = "C:\Users\User\Desktop\Testing"
    Dim fso As Object, oFolder As Object, oFile As Object, list As Object, tempString As String
    Set list = CreateObject("System.Collections.SortedList")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(PATH)
    Dim regex As New regexFileMatch
    For Each oFile In oFolder.Files
        If regex.IsFound(oFile.Name) Then
            tempString = Replace$(Left$(oFile.Name, 7), ".", vbNullString)
            With list
                If Not .contains(tempString) Then
                    .Add tempString, vbNullString
                End If
            End With
        End If
    Next
     Debug.Print list.Getkey(list.Count - 1)
End Sub

Это становится дешевле.

Источник

Мне действительно нравится ответ, который дал вам @Marcucciboy2, но в случае, если вы не можете поверить, что последний созданный файл на самом деле является тем файлом, который вам нужен, вы можете использовать (адаптировать выход) что-то вроде ниже:

Sub GetFile()

Dim YR As Long, MNTH As Long
Dim FPath As String, SearchFile As String

FPath = "U:\Test\"

For YR = Year(Now()) To 1 Step -1
    For MNTH = 12 To 1 Step -1
        If MNTH < 10 Then
            SearchFile = FPath & YR & ".0" & MNTH & " final.xlsx"
        Else
            SearchFile = FPath & YR & "." & MNTH & " final.xlsx"
        End If
        If Dir(SearchFile) <> "" Then
            Workbooks.Open (SearchFile)
            Exit Sub
        End If
    Next MNTH
Next YR

End Sub

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

Источник

Упрощенная версия, кредиты @QHarr.. Мои файлы названы как

МЕДИА-БРЕНДЫ IPG - ОБНОВЛЕНИЕ - 2020-10-12.txt

МЕДИА-БРЕНДЫ IPG - ОБНОВЛЕНИЕ - 2021-10-12.txt

Так что измените RegEx .Pattern = "\d{4}-(0?[1-9]|1[012])-(0?[1-9]|[12][0-9]|3[01])*"в соответствии с вашими потребностями

Function GetLastestFile(path)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(path)
        f = 0
        For Each oFile In oFolder.Files
            If CDate(FileDate(oFile.Name)) > f Then
                last= oFile.Name
                f = CDate(fechArchivo(oFile.Name))
            End If
        Next
    GetLastestFile = last
End Function

Function FileDate(inputString)
    Dim re As New RegExp
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\d{4}\-(0?[1-9]|1[012])\-(0?[1-9]|[12][0-9]|3[01])*"
        fechArchivo = .Execute(inputString)(0)
    End With
End Function
Источник 
Sub FileFinder() 

Dim strFile As String, strKey As String
Dim lngMax As Long, lngNumber As Long
Dim objDict As Object

Set objDictionary = CreateObject("scripting.dictionary")
intMax = 0
    strFile = Dir("C:\Users\Documents\test\*.xlsx")
    Do While Len(strFile) > 0

        intNumber = f_NumberExtractor(strFile)
        If lngMax < lngNumber Then
            lngMax = lngNumber
        End If

        If objDictionary.exists(lngNumber) = False Then
                objDictionary.Add lngNumber, strFile
         End If
        strFile = Dir
    Loop

    MsgBox objDictionary(lngMax)

End Sub

Public Function f_NumberExtractor(ByVal str As String) As Long
'Regular expression function to get rid of non-numeric signs
Dim objRegEx As Object
Dim lngResult As Long

Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Pattern = "\D"
objRegEx.Global = True


lngResult = objRegEx.Replace(str, vbNullString) * 1
f_NumberExtractor = lngResult

End Function
Источник
Другие вопросы по тегам