返回列表 上一主題 發帖

[發問] EXCEL請益,開啟特定資料夾內,不特定檔名的.xlsx檔案

[發問] EXCEL請益,開啟特定資料夾內,不特定檔名的.xlsx檔案

如何使用VBA做一個按鈕,按一下按鈕,就能開啟不特定名稱的檔案呢?

資料夾路徑如下↓
D:\AA\BB\CC\DD
檔案名稱如下↓
L-M AA R S L(XXX0001)20210820-20210823.xlsx
L-M AA R S L(XXX0002)20210824-20210827.xlsx
L-M AA R S L(XXX0002)20210828-20210831.xlsx

假設A: 今天日期是2021/08/22,那麼我想開啟L-M AA R S L(XXX0001)20210820-20210823.xlsx的檔案。

假設B: 今天日期是2021/08/29,那麼我想開啟L-M AA R S L(XXX0002)20210828-20210831.xlsx的檔案。

請問各位大大,該如何寫VBA來開啟?
已事先爬過文,都沒有想要的方式。

請各位協助,謝謝!

回復 1# zz0660

請測試看看,謝謝
Sub 選擇檔案可複選()
With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = "D:\"
    .AllowMultiSelect = True
    .Show
    fc = .SelectedItems.Count: If fc = 0 Then Exit Sub
    For x = 1 To fc
        FPath = .SelectedItems(x)
        Set WB = Workbooks.Open(FPath)
        With WB.Sheets(1)
            '需求程式
            
        End With
        WB.Close
    Next
End With
End Sub

TOP

回復 2# samwang
您好,感謝您的回答。
目前測試結果,會出現開啟檔案視窗,但選擇檔案後,無法順利開啟檔案,如下圖。
010101010.JPG
2021-8-23 13:10


有沒有辦法,會讓程式自動判斷開啟日期。
L-M AA R S L(XXX0001)20210820-20210823.xlsx

固定檔名L-M AA R S L,會不定時變更的檔名(XXX0001)20210820-20210823。
不定時變更的檔名範例
範例A: (XXX0002)20210824-20210827
範例B: (XXX0003)20210828-20210831

假設日期今天日期2021/08/22,程式能不能開啟20210820-20210823的這個檔案?

麻煩您了,謝謝!

TOP

回復 3# zz0660

資料夾路徑如下D:\AA\BB\CC\DD
假設日期今天日期2021/08/22,程式能不能開啟20210820-20210823的這個檔案?
>> 請再測試看看,謝謝

Sub test()
Dim Arr(), T$, d$, d1$, d2$, xY$, xM$, xD$
T = Date
Set fs = CreateObject("Scripting.FileSystemObject")
a = "D:\AA\BB\CC\DD"
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
    d = Split(Split(f1.Name, ")")(1), "-")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d1 = DateSerial(xY, xM, xD)
    d = Split(Split(Split(f1.Name, ")")(1), "-")(1), ".")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d2 = DateSerial(xY, xM, xD)
    If T >= d1 And T <= d2 Then
        ReDim Preserve Arr(n)
        Arr(n) = f1.Path
        n = n + 1
    End If
Next

If n > 0 Then
For i = 0 To n - 1
    Set WB = Workbooks.Open(Arr(i))
    '主程式需求
   
    WB.Close
Next
End If
End Sub

TOP

回復 4# samwang
感謝您協助處理,目前測試結果,沒辦法開啟檔案,點擊按鈕會閃一下,就沒反應。
如下圖。
253535.JPG
2021-8-23 15:54


我是將程式放在左方按鈕。

TOP

回復 5# zz0660

點擊按鈕會閃一下,就沒反應
>> 程式開啟檔案後就會直接關閉,因為沒有後續動作(沒有主程式需求),所以只有閃一下,
我測試沒問題如附件,謝謝
擷取.PNG

TOP

回復 6# samwang

感謝 samwang 大大協助處理問題,已經是我想要的樣子了,謝謝您。

您提供的程式如下↓

Sub test()
Dim Arr(), T$, d$, d1$, d2$, xY$, xM$, xD$
T = Date
Set fs = CreateObject("Scripting.FileSystemObject")
a = "D:\AA\BB\CC\DD"
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
    d = Split(Split(f1.Name, ")")(1), "-")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d1 = DateSerial(xY, xM, xD)
    d = Split(Split(Split(f1.Name, ")")(1), "-")(1), ".")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d2 = DateSerial(xY, xM, xD)
    If T >= d1 And T <= d2 Then
        ReDim Preserve Arr(n)
        Arr(n) = f1.Path
        n = n + 1
    End If
Next

If n > 0 Then
For i = 0 To n - 1
    Set WB = Workbooks.Open(Arr(i))
    '主程式需求
   
    WB.Close    ← 將這段移除,就是我要的樣子。
Next
End If
End Sub

再次感謝您,一直以來的協助處理問題,謝謝!

TOP

回復 4# samwang

您好,我使用此段程式碼↓
Sub test()
Dim Arr(), T$, d$, d1$, d2$, xY$, xM$, xD$
T = Date
Set fs = CreateObject("Scripting.FileSystemObject")
a = "D:\AA\BB\CC\DD"
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
    d = Split(Split(f1.Name, ")")(1), "-")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d1 = DateSerial(xY, xM, xD)
    d = Split(Split(Split(f1.Name, ")")(1), "-")(1), ".")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d2 = DateSerial(xY, xM, xD)
    If T >= d1 And T <= d2 Then
        ReDim Preserve Arr(n)
        Arr(n) = f1.Path
        n = n + 1
    End If
Next

If n > 0 Then
For i = 0 To n - 1
    Set WB = Workbooks.Open(Arr(i))
    '主程式需求
  
Next
End If
End Sub

今天我在 D:\AA\BB\CC\DD 路徑下又新增 不同檔名的檔案,就會出現問題。
如下圖↓
8888.JPG
2021-9-5 14:09


我新增的檔案及名稱如下圖
8887.JPG
2021-9-5 14:13

新增檔案名稱如下

20170831-請協助打上檔案名稱-Xjl
ZXZ0099X0.0-部品名冊清單-2019
ZXZ0099X1.0-20190101標示


主要是指針對以下檔名開啟
7524.JPG
2021-9-5 14:15

不會因為其他檔名而開啟不了檔案。

目前個人認為可能是Split,這邊的問題吧?

還請大大協助,謝謝!

TOP

回復 8# zz0660


  不會因為其他檔名而開啟不了檔案。
目前個人認為可能是Split,這邊的問題吧?  

>> 新增如下紅字,請再測試,謝謝
Sub test()
Dim Arr(), T$, d$, d1$, d2$, xY$, xM$, xD$
T = Date
Set fs = CreateObject("Scripting.FileSystemObject")
a = "D:\AA\BB\CC\DD"
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
    If UCase(Left(f1.Name, 3)) <> "L-M" Then GoTo 99
    d = Split(Split(f1.Name, ")")(1), "-")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d1 = DateSerial(xY, xM, xD)
    d = Split(Split(Split(f1.Name, ")")(1), "-")(1), ".")(0)
    xY = Left(d, 4): xM = Mid(d, 5, 2): xD = Right(d, 2)
    d2 = DateSerial(xY, xM, xD)
    If T >= d1 And T <= d2 Then
        ReDim Preserve Arr(n)
        Arr(n) = f1.Path
        n = n + 1
    End If
99: Next

...
...

TOP

回復 8# zz0660

試試看,用like,不用split~

    Sub test()

Dim fs As Object, f, fc, f1, d1, d2, d3
Set fs = CreateObject("Scripting.FileSystemObject")
a = "D:\AA\BB\CC\DD"
Set f = fs.GetFolder(a)
Set fc = f.Files
d3 = Format(Now(), "yyyymmdd")

For Each f1 In fc

    If f1.Name Like "L-M AA R S L(?*.xlsx" Then
         d1 = Mid(f1.Name, 22, 8)
        d2 = Mid(f1.Name, 31, 8)
      If d3 >= d1 And d3 <= d2 Then
             DoEvents
             Set WB = Workbooks.Open(f1)
        End If
    End If
Next

Set fs = Nothing

End Sub

TOP

        靜思自在 : 受人點水之恩,須當湧泉以報。
返回列表 上一主題