Option Explicit
Sub TEST()
Dim Arr, i%, Ph$, xS As Worksheet, xB As Workbook, K%
Application.ScreenUpdating = False
Set xB = ThisWorkbook: Ph = xB.Path & "\"
Arr = Range([順序!E2], [順序!C65536].End(3))
Sheets("集中").Cells.Clear
For i = 1 To UBound(Arr)
On Error Resume Next
Set xS = Workbooks(Arr(i, 1) & ".xlsx").Sheets(Arr(i, 2))
If Err.Number <> 0 Then
Set xS = Workbooks.Open(Ph & Arr(i, 1) & ".xlsx").Sheets(Arr(i, 2))
K = 1
End If
On Error GoTo 0
If xS Is Nothing Then
MsgBox Arr(i, 1) & " 活頁簿, " & Arr(i, 2) & " 工作表不存在!結束執行"
Exit Sub
End If
xS.[A:I].Copy xB.Sheets("集中").Cells(1, Arr(i, 3))
If K = 1 Then xS.Parent.Close 0: K = 0
Set xS = Nothing
Next
Set xB = Nothing: Erase Arr
End Sub作者: singo1232001 時間: 2023-10-16 13:56
Sub test2()
Set CN = CreateObject("adodb.connection"): V = Application.Version
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;"
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;"
Set s = Sheets("順序"): Set s0 = Sheets("集中"): s0.Cells.ClearContents
AR = Array("select * from [sheet1$A:I]", "select * from [工作表1$A:I]")
For i = 2 To s.Cells(Rows.Count, 2).End(3).Row
If Dir(ThisWorkbook.Path & "\" & s.Cells(i, "C") & ".xlsx") <> "" Then
CN.Open V & "Data Source=" & ThisWorkbook.Path & "\" & s.Cells(i, "C") & ".xlsx"
On Error Resume Next
Set rs = CN.Execute("select * from [" & s.Cells(i, "D") & "$A:I]")
If CN.Errors.Count <> 0 Then: CN.Errors.Clear: Set rs = CN.Execute(AR(0))
If CN.Errors.Count <> 0 Then: CN.Errors.Clear: Set rs = CN.Execute(AR(1))
On Error GoTo 0
s0.Range(s.Cells(i, "E") & 2).CopyFromRecordset rs
s0.Columns(s.Cells(i, "E").Value).NumberFormatLocal = "h:mm:ss;@"
s0.Range(s.Cells(i, "E") & 6).Resize(1, 9) = Split("A,B,C,D,E,F,G,H,I", ",")
CN.Close
End If
Next
End Sub作者: Andy2483 時間: 2023-10-16 14:32
Option Explicit
Sub TEST()
Dim Arr, i%, Ph$, xS As Worksheet, xB As Workbook, K%, T1$, T2$
Application.ScreenUpdating = False
Set xB = ThisWorkbook: Ph = xB.Path & "\"
Arr = Range([順序!E2], [順序!C65536].End(3))
Sheets("集中").Cells.Clear
For i = 1 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 2)
On Error Resume Next
Set xS = Workbooks(T1 & ".xlsx").Sheets(T2)
If Err.Number <> 0 Then
Set xS = Workbooks.Open(Ph & T1 & ".xlsx").Sheets(T2)
K = 1
End If
On Error GoTo 0
If xS Is Nothing Then
MsgBox T1 & " 活頁簿, " & T2 & " 工作表不存在!結束執行"
Exit Sub
End If
xS.[A:I].Copy xB.Sheets("集中").Cells(1, Arr(i, 3))
If K = 1 Then xS.Parent.Close 0: K = 0
Set xS = Nothing
Next
Set xB = Nothing: Erase Arr
End Sub作者: Andy2483 時間: 2023-10-18 08:18
Option Explicit
Sub TEST()
Dim Arr, i%, K%, xS As Worksheet, xB As Workbook, Ph$, T1$, T2$
'↑宣告變數:Arr是通用型變數,(i,K)是短整數,(Ph,T1,T2)是字串變數,xS是工作表變數
'xB是活頁簿變數
Application.ScreenUpdating = False
'↑令螢幕不隨著程序執行結果做變化
Set xB = ThisWorkbook: Ph = xB.Path & "\"
'↑令xB這活頁簿變數是 本檔
'令Ph這字串變數是本檔所在路徑連接"\"所組成的字串
Arr = Range([順序!E2], [順序!C65536].End(3))
'↑令Arr這通用型變數是 二維陣列,以"順序"表[E2]到C欄最後有內容儲存格,
'以這範圍儲存格值帶入
Sheets("集中").Cells.Clear
'↑令"集中"工作表全部儲存格清除內容
For i = 1 To UBound(Arr)
'↑設順迴圈!令i從1到 Arr陣列縱向最大索引列號
T1 = Arr(i, 1) & ".xlsx": T2 = Arr(i, 2)
'↑令T1這字串變數是 i迴圈列第1欄Arr陣列值連接".xlsx"組成的字串
'令T2這字串變數是 i迴圈列第2欄Arr陣列值字串
On Error Resume Next
'↑令程序不偵錯
Set xS = Workbooks(T1).Sheets(T2)
'↑令xS這工作表變數是 名為(T1變數)活頁簿裡,名為(T2變數)的工作表
If Err.Number <> 0 Then
'↑如果傳回或設定指定錯誤的數值不是 0? https://learn.microsoft.com/zh-t ... ic-for-applications
Set xS = Workbooks.Open(Ph & T1).Sheets(T2)
'↑令XS變數是開啟Ph變數路徑下名為T1變數活頁簿裡,名為T2變數工作表
K = 1
'↑令K這短整數變數是 1
End If
On Error GoTo 0
'↑令程序恢復偵錯
If xS Is Nothing Then
'↑如果xS變數不是物件?
MsgBox T1 & " 活頁簿, " & T2 & " 工作表不存在!結束執行": Exit Sub
'↑令跳出提視窗~~~,結束程序執行
End If
xS.[A:I].Copy xB.Sheets("集中").Cells(1, Arr(i, 3))
'↑令xS變數的[A:I]儲存格複製到 xB活頁簿(本檔)"集中"工作表的第1列(指定欄)儲存格
'指定欄:i迴圈列第3欄Arr陣列值
If K = 1 Then xS.Parent.Close 0: K = 0
'↑如果K變數是1?(代表xS工作表的活頁簿是執行程序中開啟的),
'True就令其關閉,令K變數歸零
Set xS = Nothing
'↑令xS變數釋放
Next
Set xB = Nothing: Erase Arr
'↑令釋放變數
End Sub
