[attach]33932[/attach]

7C機資料夾內共有1~98個檔案(本題以5個檔案為例)。

>> 由大至小開啟檔案，修改如下紅字部分，請測試看看，謝謝

Private Sub CommandButton1_Click()
Dim Path As String, a, Ar(1 To 1000, 1 To 2)
Nrange = "1878" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
Tm = Timer
[L1] = ""

Set fs = CreateObject("Scripting.FileSystemObject")
Path = ThisWorkbook.Path
a = Path & "\7C機"
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
n = n + 1
Ar(n, 1) = a & "\" & f1.Name
Ar(n, 2) = Split(Split(f1.Name, "_")(3), "-")(0)
Next
For i = 1 To UBound(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
Set WB = Workbooks.Open(Ar(i, 1))
WB.Close
Next

With Sheets("Sheet1")
.[A1] = Nrange
.[A2].Formula = "=CountA(M1:GZ1) / 2 & ""個""": .[A2] = .[A2].Value
.[A3] = "開獎號碼"
...
...

>> 程式如下紅字，請測試看看，謝謝

For i = 1 To UBound(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

fileOrg = ActiveWorkbook.Name
C = 13
For i = 1 To n
Set WB = Workbooks.Open(Ar(i, 1))
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

With Sheets("Sheet1")
.[A1] = Nrange
.[A2].Formula = "=CountA(M1:GZ1) / 2 & ""個""": .[A2] = .[A2].Value
.[A3] = "開獎號碼"
.[A4:A10].Formula = "=IF(A\$1="""","""",VLOOKUP(A\$1,DATA!\$A:\$H,ROW()-2,

OK了

[attach]33946[/attach]
Samwang大大：您好!

PS：效果檔的內容與5樓的效果檔相同。

>> 程式如下，請測試看看，謝謝

Private Sub CommandButton1_Click()
Dim Path\$, a, Ar(1 To 1000, 1 To 2), Ar1()
Nrange = "1878" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
Tm = Timer
[L1] = ""
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
...
...

samwang大大 : 您好 !

[attach]33947[/attach]

Private Sub CommandButton1_Click()
Dim Path As String, a, Ar(1 To 1000, 1 To 2), Ar1( )

Dim Path As String, a, Ar(1 To 1000, 1 To 2), Ar1( )

Sorry~原來是我在貼8#的程式碼時，就疏忽遺漏了

[attach]33960[/attach]

>> 因為 n 前面程式碼已有使用過且有數值，所以將n改m 即可，For j = 2 To 8: m = m + 1: Brr(m) = Arr(i, j): Next ,謝謝

samwang大大 :
OK了!

 歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)