- 帖子
- 1425
- 主題
- 40
- 精華
- 0
- 積分
- 1449
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-4-16
|
本帖最後由 Andy2483 於 2023-2-13 11:57 編輯
回復 1# rcyw
回復 2# 准提部林
謝謝 rcyw前輩發表此主題與範例,謝謝 准提部林前輩範例指導
學習心得註解如下,請前輩再指導
Sub combine()
Dim Arr, Brr, PH$, FN$, xB As Workbook, xS As Worksheet, i&, N&
'↑宣告變數!(Arr,Brr)是通用型變數,(PH,FN)是字串變數,xB是活頁簿變數,
'xS是工作表變數,(i,N)是長整數變數
ReDim Brr(1 To 60000, 0)
'↑宣告Brr為二維陣列,陣列大小:縱向從1索引號列 到60000索引號列,
'橫向從0索引號欄 到 0索引號欄
Application.ScreenUpdating = False
'↑令螢幕暫不隨程式執行作變化
PH = ThisWorkbook.Path & "\TEST"
'↑令PH這字串變數是 本檔案的完整路徑字串連接 "\TEST" 的新字串
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.workbook.path
FN = Dir(PH & "\*.xls*")
'↑令Dir 函數回傳 (路徑與檔案類型:PH變數連接 "\*.xls*" )給FN這字串變數
Do While FN <> ""
'↑設條件迴圈!當FN變數不是空字元時,繼續執行
Set xB = Workbooks.Open(PH & "\" & FN)
'↑開啟(PH變數 連接 "\" & FN變數組合成的新字串路徑檔案,並令xB這活頁簿變數是他
For Each xS In xB.Sheets
'↑設逐次迴圈!令xS這工作表變數是 xB變數裡的工作表
If xS.Name Like "Script_*" = False Then GoTo x01
'↑如果xS變數的名字不是 以 "Script_" 開頭的字串!就跳到 x01標示處繼續執行
Arr = Range(xS.[a1], xS.Cells(Rows.Count, 1).End(3)(2))
'↑令Arr這通用型變數是 xS變數[A1]到A欄最後一有內容儲存格的下一格(空白格),
'以這範圍儲存格值倒入 這Arr二維陣列裡
For i = 1 To UBound(Arr) - 1
'↑設順迴圈!i從1到 Arr陣列縱向索引列號 -1
If Arr(i, 1) <> "" Then N = N + 1: Brr(N, 0) = Arr(i, 1)
'↑如果i迴圈列/第1欄Arr陣列值不是空字元!就令N這長整數變數累加1,
'令N變數列0索引號欄 Brr陣列值是 i迴圈列/第1欄Arr陣列值
Next i
x01: Next
xB.Close 0
'↑令xB變數,不儲存關閉
FN = Dir
'↑令FN變數是 Dir的下一個項目
Loop
Set xB = Nothing: Set xS = Nothing
'↑令這兩個物件變數清空
'=============================
ThisWorkbook.Activate
'↑令回到本檔
If N = 0 Then Exit Sub
'↑如果N變數是 0!就結束程式執行
Application.DisplayAlerts = False
'↑令不要再跳出提示:問工作表是不是要刪除!就直接刪除!不要再問了!
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.application.displayalerts
On Error Resume Next
'↑令從此處開始的程序遇到錯誤時不要偵錯!跳過該程序繼續執行
Sheets("Combine").Delete
'↑令 "Combine"工作表刪除
On Error GoTo 0
'↑令程序從此處開始恢復偵錯
With Worksheets.Add(After:=Sheets(Sheets.Count))
'↑以下是關於在最後新增加一個工作表後的程序
.[a1].Resize(N) = Brr
'↑令新增工作表的[A1]擴展向下N列的範圍儲存格值,以Brr陣列值倒入
.Name = "Combine"
'↑令新增工作表的名字是 "Combine"
End With
Sheets(1).Select
'↑選取第1個工作表
End Sub |
|
發表於 2023-2-13 11:55
| 
