Private Sub CommandButton1_Click()
Dim Path$, xD1, A, Ar(1 To 5000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, xD, T%, i&, j&, k&
Application.DisplayAlerts = False: Application.ScreenUpdating = False
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
fileOrg = ActiveWorkbook.Name
Tm = Timer
Nrange = InputBox("請輸入DATA!的開獎期數", "輸入期數")
num = "100" 'InputBox("請輸入效果檔A︰H複製的期距數範圍", "輸入距期數")
Order = "0" ' InputBox("請輸入增加的邏輯條件條件之起迄序號", "輸入序號(1~99)或不增加(按Enter)")
Ncount = "1" ' InputBox("請輸入驗證版的連續次數", "輸入次數(1~10)")
Sheets("DATA").[L1:L4] = ""
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): xD1(Ar(n, 2)) = 1
Next
For Each Ky In xD1
For x = 1 To n '開啟Ar,找同類型資料夾，檔名有"機"裝入Ar1
If Ar(x, 2) = Ky Then
Set f = fs.GetFolder(Ar(x, 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
End If
Next x
C = 13
If n1 > 0 Then For i1 = 0 To n1 - 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
ActiveWindow.Close
With Sheets("Sheet1")
.[A1:A10].ClearContents: .[B:IV].Clear
End With
n1 = 0: m = 0: xD.RemoveAll: s = 0
Next作者: ziv976688 時間: 2021-9-17 12:20
