- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-10-30
|
8#
發表於 2021-8-24 08:05
| 只看該作者
本帖最後由 samwang 於 2021-8-24 08:09 編輯
回復 7# ziv976688
以各資料夾名稱的第5段數字為基準(EX：7C _0_1878期_100_1877-10_1次)~由大而小開啟的程式碼；
然後將各開啟後的資料夾中有關鍵字"機"的檔案(EX：7C機_1878期_100_1877-10_1次)開啟~
再將該開啟後的檔案內之"機率表"的A&B二欄內容複製後，
依序由主檔之"Sheet1!"的M1往右貼上。
>> 程式如下，請測試看看，謝謝
Private Sub CommandButton1_Click()
Dim Path$, a, Ar(1 To 1000, 1 To 2), Ar1()
Nrange = "1878" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
Tm = Timer
[L1] = ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
a = ThisWorkbook.Path '每個資料夾名稱裝入Ar
Set f = fs.GetFolder(a)
Set fc = f.SubFolders
For Each f1 In fc
n = n + 1
Ar(n, 1) = f1.Path
Ar(n, 2) = Split(Split(f1.Name, "_")(4), "-")(0)
Next
For i = 1 To UBound(Ar) 'Ar由大至小排序
For j = i + 1 To UBound(Ar)
If Ar(i, 2) < Ar(j, 2) Then
a = Ar(i, 1)
Ar(i, 1) = Ar(j, 1)
Ar(j, 1) = a
End If
Next j
Next i
For i = 1 To n '開啟Ar，找檔名有"機"裝入Ar1
Set f = fs.GetFolder(Ar(i, 1))
Set fc = f.Files
For Each f1 In fc
If InStr(f1.Path, "機") Then
ReDim Preserve Ar1(n1)
Ar1(n1) = f1.Path
n1 = n1 + 1
End If
Next f1
Next i
fileOrg = ActiveWorkbook.Name
C = 13
If n1 > 0 Then
For i1 = 0 To n - 1 '開啟Ar1，copy A、B欄資料到Sheet1 M欄開始往右
Set WB = Workbooks.Open(Ar1(i1))
With Sheets(1)
If .FilterMode Then .ShowAllData
.Range("a1:b" & .[a65536].End(3).Row).Copy Workbooks(fileOrg).Sheets("Sheet1").Cells(1, C)
C = C + 2
End With
WB.Close
Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
With Sheets("Sheet1")
.[A1] = Nrange
...
... |
|
