[發問] 複製搜尋指定名稱工作表

　暱稱: 厚臉皮的學生

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

3^#

發表於 2023-2-13 11:55 | 只看該作者

本帖最後由 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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

4^#

發表於 2023-2-13 14:07 | 只看該作者

回復 2# 准提部林

謝謝前輩

Arr = Range(xS.[a1], xS.Cells(Rows.Count, 1).End(3)(2))
是為了處理符合條件的空白工作表

因此迴圈需要 -1
For i = 1 To UBound(Arr) - 1

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

rcyw

帖子: 16
主題: 5
精華: 0
積分: 71
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2023-6-18

5^#

發表於 2023-2-19 03:13 | 只看該作者

謝謝准提部林的回覆, 真的得益不少....

另外Andy2483..你的註解也很用心...大家也是一齊學習中.

rcyw

帖子: 16
主題: 5
精華: 0
積分: 71
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2023-6-18

6^#

發表於 2023-2-21 22:49 | 只看該作者

回復 2# 准提部林

准提部林大大....用公司中的檔案試了一下, 搜尋時好像停止了, 自己看一下不知如何修改, 可否幫忙看一下, 先謝謝...

附件模擬一下公司中的檔案...都是只想搜尋名稱是 "Script_*的工作表, 再只將 A列中的全部值合併複製到一張新的工作表中.

combine.zip (134.68 KB)

　暱稱: 厚臉皮的學生

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

7^#

發表於 2023-2-22 07:55 | 只看該作者

回復 6# rcyw

謝謝前輩
1.下載範例檔做測試,發現了一個錯誤值,建議前輩下圖片中的錯誤值是該修正或刪除
2.後學刪除錯誤值後做測試是沒問題的
3.祝有美好的一天

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

rcyw

帖子: 16
主題: 5
精華: 0
積分: 71
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2023-6-18

8^#

發表於 2023-2-22 09:50 | 只看該作者

回復 7# Andy2483

先謝謝Andy2483兄.
在公司的工作表中有時會出現 "#N/A"...可否將這個值不複製跳過就可以了...

　暱稱: 厚臉皮的學生

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

9^#

發表於 2023-2-22 10:47 | 只看該作者

回復 8# rcyw

謝謝前輩再回復
試修改如下,請前輩再試試看

Sub combine()
Dim Arr, Brr, PH$, FN$, xB As Workbook, xS As Worksheet, i&, N&
ReDim Brr(1 To 60000, 0)
Application.ScreenUpdating = False
PH = ThisWorkbook.Path & "\TEST"
FN = Dir(PH & "\*.xls*")
Do While FN <> ""
Set xB = Workbooks.Open(PH & "\" & FN)
For Each xS In xB.Sheets
   If xS.Name Like "Script_*" = False Then GoTo x01
   With Range(xS.[a1], xS.Cells(Rows.Count, 1).End(3)(2))
      On Error Resume Next
      With .SpecialCells(xlCellTypeConstants, 16)
            Application.Goto .Cells: MsgBox "修正錯誤": Exit Sub
         '↑建議檢查/修正資料檔錯誤值存檔關閉後再重新執行
            '資料檔的錯誤格追究其原因是很重要的
            '.ClearContents
            '↑不建議直接清除跳過
      End With
      On Error GoTo 0
   Arr = .Value
   End With
   For i = 1 To UBound(Arr) - 1
         If Arr(i, 1) <> "" Then N = N + 1: Brr(N, 0) = Arr(i, 1)
   Next i
x01: Next
xB.Close 0
FN = Dir
Loop
Set xB = Nothing: Set xS = Nothing
'=============================
ThisWorkbook.Activate
If N = 0 Then Exit Sub
Application.DisplayAlerts = False
On Error Resume Next: Sheets("Combine").Delete: On Error GoTo 0
With Worksheets.Add(After:=Sheets(Sheets.Count))
   .[a1].Resize(N) = Brr
   .Name = "Combine"
End With
Sheets(1).Select
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

rcyw

帖子: 16
主題: 5
精華: 0
積分: 71
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2023-6-18

10^#

發表於 2023-2-22 14:01 | 只看該作者

回復 9# Andy2483

謝謝Andy2483兄的修改，..用 clearcontents...已可用了，真的非常感謝。