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

rcyw

本人想搜尋一個excel檔內, 指定的工作表中, 只想搜尋所有名稱是 "Script_*的工作表, 再只張 A列中的全部值, 合併複製到一張新的工作表中.....如A列是空格, 就不複製, 只複製有值的格數...

但自己的vba不知如何搜尋指定名稱工作表, 只能寫出全部工作表都複製....

希望高手們幫忙改一下, 先謝謝.

准提部林

參考檔//路徑須自行更改
TEMP001.rar (33.06 KB)

下載次數: 12

2023-2-11 23:06

Andy2483

回復 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

Andy2483

回復 2# 准提部林


    謝謝前輩

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

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

rcyw

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

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

rcyw

回復 2# 准提部林

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

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

Andy2483

回復 6# rcyw

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

下載 (11.84 KB)

2023-2-22 07:51

rcyw

回復 7# Andy2483

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

Andy2483

回復 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

回復 9# Andy2483

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