根据具有特定范围日期时间的文件名打开excel文件（一一）

Question

我正在寻找一个 vba 代码来帮助过滤特定的日期范围。开始日期和结束日期在文件夹中格式为 YYYYMMDD 的文件名中找到 shown here.

我正在尝试打开特定日期范围内的所有文件，一个一个地复制其中的一些数据，然后粘贴到另一个工作簿 (A_2021.xlsm)。

我尝试使用单个日期时间并成功，但我不知道如何根据文件名过滤特定日期范围。请查看我的代码，以防单日期如下，如果对日期范围有任何想法，请帮助我。非常感谢！ Additional screenshot

Sub singledateOMS()
    Dim reportdate2 As String
    reportdate2 = Workbooks("A_2021.xlsm").Sheets("1").Cells(4, 3).Value
    
    answer = MsgBox("Are you sure to re-update?", vbQuestion + vbYesNo + vbDefaultButton2, "QConfirm")
    
    If answer = vbYes Then
        Dim ws1 As Worksheet
        Dim ws3 As Worksheet
        Dim bookName3 As String
        Dim sheetName3 As String
        Dim uDay As String
        Dim uMonth As String
        Dim uYear As String
        
        uDay = Format(reportdate2, "dd")
        uMonth = Format(reportdate2, "mm")
        uYear = Format(reportdate2, "yyyy")
        

        bookName3 = uYear & uMonth & uDay & ".csv"
        sheetName3 = uYear & uMonth & uDay

        Application.ScreenUpdating = False
        
        Workbooks.Open Filename:="C:\Users\" & bookName3
        Set ws3 = Workbooks(bookName3).Sheets(sheetName3)
        With ws3
            Dim xResult As String
            Dim yResult As String
            Dim xTankId As String
            Dim yTankId As String
            Dim Separator As String
            Separator = vbCrLf 'vbCrlf
    
            Dim d As dictionary
            Set d = New dictionary
            
            Dim LastRowNew As Long
            LastRowNew = .Cells(Rows.Count, 7).End(xlUp).Row
            For i = 2 To LastRowNew
                xTankId = .Cells(i, 7).Value '& "-" & .Cells(i, 7).Value
                xResult = .Cells(i, 7).Value & " / " & .Cells(i, 8).Value & " @ " & .Cells(i, 9).Value & " / " & .Cells(i, 12).Value & " / " & .Cells(i, 10).Value & " / " & .Cells(i, 11).Value & " / " & .Cells(i, 5).Value & " / " & .Cells(i, 6).Value
                yTankId = .Cells(i, 8).Value '& "-" & .Cells(i, 7).Value
                yResult = .Cells(i, 7).Value & " / " & .Cells(i, 8).Value & " @ " & .Cells(i, 9).Value & " / " & .Cells(i, 12).Value & " / " & .Cells(i, 10).Value & " / " & .Cells(i, 11).Value & " / " & .Cells(i, 5).Value & " / " & .Cells(i, 6).Value
                If d.Exists(xTankId) Then
                    xResult = d(xTankId) & Separator & xResult
                    d(xTankId) = xResult
                Else
                    d(xTankId) = xResult
                End If
                If d.Exists(yTankId) Then
                    yResult = d(yTankId) & Separator & yResult
                    d(yTankId) = yResult
                Else
                    d(yTankId) = yResult
                End If
            Next

    
            Set ws1 = Workbooks("A_2021.xlsm").Sheets("1")

            With ws1
            'Add column header
            Dim LastCol4 As Long
            LastCol4 = .Cells(8, .Columns.Count).End(xlToLeft).column
            '.Cells(8, LastCol4 + 1) = date_in
    
            Dim iiiCol As Long
            iiiCol = 1
            Do Until Format(.Cells(8, iiiCol).Value, "YYYY/MM/DD") = Format(reportdate2, "YYYY/MM/DD")
                iiiCol = iiiCol + 1
            Loop
            
            Dim LastRow3 As Long
            LastRow3 = .Cells(Rows.Count, 2).End(xlUp).Row
    
            For i = 2 To LastRow3
                xTankId = .Cells(i, 2).Value
                yTankId = .Cells(i, 2).Value
                If d.Exists(xTankId) Then
                    .Cells(i, iiiCol).Value = d(xTankId)
                End If
                If d.Exists(yTankId) Then
                    .Cells(i, iiiCol).Value = d(yTankId)
                End If
            Next i
            End With
        End With
    Application.DisplayAlerts = False  'Disable the popups asking for confirm for saving
    Workbooks(bookName3).Close saveChanges:=False
    Else
    
    End If
End Sub

Answer 1

要过滤特定的日期范围，您可能需要设置 2 个单元格来存储开始日期和结束日期，例如，我们将 A1 和 A2 设置为开始日期和结束日期：

子 singledateOMS()

folder_path = "" 'where you save all .csv files

start_date = CDate(ThisWorkbook.Sheets(1).Cells("A1").Text)
end_date = CDate(ThisWorkbook.Sheets(1).Cells("A2").Text)

Set date_dic = CreateObject("script.dictionary")

For i = start_date to end_date
    date_dic(Format(i, "yyyyMMdd") & ".csv") = ""
Next i

current_file = Dir(folder_path & "\*.csv")
Do While current_file <> ""
    
    If date_dic.exists(current_file) Then
        Set eapp = CreateObject("excel.application")
        Set efile = eapp.Workbooks.Open(folder_path & "\" & current_file)

        'efile is the file you want
        'copy paste process codes



        efile.Close
        Set efile = Nothing
        eapp.Quit
        Set eapp = Nothing
    End If

    MyFile = Dir
    If MyFile = "" Then
        Exit Do
    End If
Loop

结束子

Answer 2

这是获取文件名的方式。

Option Explicit

Public Function GetFileNames(ByVal startDate As Date, ByVal endDate As Date) As Collection

    ' Change "C:\User\" to the name of the folder containing the data files.
    ' You might also decide to pass it in as a parameter.
    Const path As String = "C:\User\"

    Dim startFileName As String
    Dim endFileName As String
    Dim fileName As String
    
    Set GetFileNames = New Collection
    
    startFileName = Format(startDate, "YYYYMMDD") & ".CSV"
    endFileName = Format(endDate, "YYYYMMDD") & ".CSV"
    
    fileName = Dir(path & "*.csv")
    
    Do While fileName <> ""
        
        Select Case fileName
            
            Case Is < startFileName
                ' skip
            
            Case Is <= endFileName
                GetFileNames.Add path & fileName
            
            Case Else
                Exit Do
        
        End If

        ' Next file name.
        fileName = Dir()
    
    Loop

End Function

像这样调用 GetFileNames。

Public Sub Main()

    Dim fileName As String

    ' You need to provide the start & end dates
    For Each fileName In GetFileNames(startDate, endDate)

        ' Open file, read, copy data, close, etc.
    
    Next fileName

End Sub