搜尋指定工作表再全頁複製到另一檔案中

rcyw

在公司的檔案中, 有些工作表是不太有用, 自己想將有用的工作表, 從原檔案中全頁複製到另一excel檔中, ...

公司原檔"Basic_xxx", 將以下名稱全頁複製到 "10xxx_New_v2" 檔中同名稱位置....
Base Station Transport Data/Data_LTE/Data_NR/LTE Cell/NR Cell/NRDUCELL/NRDUCellCoverage

想在"10xxx_New_v2"第一頁中, 加了一個按鈕, 一按下就可將原檔內的工作表複製....

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

准提部林

副檔名 xls 須自行更改為 xlsx
新資料夾001.rar (283.25 KB)

下載次數: 12

2023-3-4 11:50

rcyw

回復 2# 准提部林

再次感謝 准提部林 大大的回覆, 真的省下自己逐頁copy的時間, 非常好用.....:)

Andy2483

回復 1# rcyw
回復 2# 准提部林


    謝謝 rcyw前輩發表此主題與範例
謝謝 准提部林前輩指導
後學學習心得如下請前輩指導

Sub 複製指定工作表()
Dim Fn$, Sn$, S, uBook As Workbook, uSht As Worksheet, xBook As Workbook, xS As Worksheet
'↑宣告變數:(Fn,Sn)是字串變數,S是通用型變數,
'(uBook,xBook)是活頁簿變數,(uSht,xS)是工作表變數
Set uBook = ThisWorkbook
'↑令uBook這活頁簿變數是 本活頁簿
Fn = Sheet1.[P2] & ".xls"
'↑令Fn這字串變數是 第一個工作表的[P2]儲存格值,連接".xls"的新字串
On Error Resume Next: Set xBook = Workbooks(Fn): On Error GoTo 0
'↑令程序遇錯暫跳過錯誤執行下個程序:令xBook這活頁簿變數是 名為Fn變數的活頁簿,
'接著就恢復偵錯
If xBook Is Nothing Then Set xBook = Workbooks.Open(uBook.Path & "\" & Fn)
'↑如果xBook變數是不存在(還沒被開啟)!就開啟在本活頁簿資料夾裡的Fn變數的活頁簿
uBook.Activate
'↑啟用uBook變數
Sn = "Base Station Transport Data/Data_LTE/Data_NR/LTE Cell/NR Cell/NRDUCELL/NRDUCellCoverage"
'↑令Sn這字串變數是 以"/"連接7個工作表名稱的字串
Application.ScreenUpdating = False
'↑令螢幕暫不隨著程序的執行作結果變化
For Each S In Split(Sn, "/")
'↑設順迴圈!令S這通用型變數是 一維陣列裡的一員,
'一維陣列:以"/"符號分割Sn變數的字串陣列
    On Error Resume Next
    '↑令程序遇錯暫跳過錯誤執行下個程序
    Set xS = xBook.Sheets(S & "")
    '↑令xS這工作表變數是 xBook變數活頁簿(另開啟檔)的 名為S變數工作表
    Set uSht = uBook.Sheets(S & "")
    '↑令uSht這工作表變數是 uBook變數活頁簿(本檔)的 名為S變數工作表
    On Error GoTo 0
    '↑令恢復偵錯
    If xS Is Nothing Then MsgBox "公司原檔找不到〔" & S & "〕工作表!!!": GoTo s01
    '↑如果xS是不存在!就跳出提視窗~~!按確定鈕後跳到 s01標示的程序位置繼續執行
    If uSht Is Nothing Then MsgBox "本檔案找不到〔" & S & "〕工作表，請確認後再重新執行!!!": Exit Sub
    '↑如果uSht是不存在!就跳出提視窗~~!按確定鈕後 結束程式執行
    uSht.UsedRange.Clear
    '↑令uSht變數的有使用儲存格做 清除
    Range(xS.[a1], xS.UsedRange).Copy uSht.[a1]
    '↑令xS變數的[A1]聯集有使用儲存格擴展至最小方正範圍儲存格,複製到uSht變數的[A1]儲存格
    Set xS = Nothing: Set uSht = Nothing
    '↑令釋放變數
s01: Next S
xBook.Close 0
'↑令xBook變數關閉(0是不存檔)
uBook.Sheets(1).Select
'↑令螢幕畫面落在本檔第一個工作表
End Sub

shuo1125

回復 2# 准提部林
rcyw 版大不好意思借搭版!
准大好!
想請問若有多工作簿多工作表複製是否可單一程序碼執行完成....?
詳如附件，可否勞煩准大抽空解答?感激不盡~!

Andy2483

回復 5# shuo1125


    謝謝前輩發表此帖
後學練習以迴圈執行副程式的方案,請前輩參考
請各位前輩指導

Dim Fn_ALL, Sn_ALL, x%
'↑宣告同模組變數:(Fn_ALL,Sn_ALL)是通用型變數,x是短整數變數
Sub Copysheets()
Fn_ALL = Array([A2], [A3]): Sn_ALL = Array("A/B/C", "D/E/F")
'↑令Fn_ALL這同模組變數是一維陣列,以[A2],[A3]兩個儲存格帶入
'↑令Sn_ALL這同模組變數是一維陣列,以"A/B/C", "D/E/F"兩個字串帶入
If UBound(Fn_ALL) <> UBound(Sn_ALL) Then Exit Sub
'↑如果Fn_ALL陣列最後索引號 <> Sn_ALL陣列最後索引號!就結束程式執行
'↑活頁簿與工作表不對稱不執行
For x = 0 To UBound(Fn_ALL)
'↑設順迴圈!x從0到 Fn_ALL陣列最後索引號
   Call 複製指定工作表
   '↑令執行(複製指定工作表)副程式
Next
MsgBox "已複製完畢"
End Sub
Sub 複製指定工作表()
Dim Fn$, Sn$, S, tBook As Workbook, tSht As Worksheet, sBook As Workbook, Sw As Worksheet
Application.ScreenUpdating = False
Set tBook = ThisWorkbook
Fn = Fn_ALL(x).Value & ".xlsx"
'↑令Fn這字串變數是 第x變數索引號的Fn_ALL變數(陣列)值 連接".xlsx"字串後的新字串
'Array([A2], [A3])是以儲存格帶入陣列,不是字串,所以要加 .Value
On Error Resume Next: Set sBook = Workbooks(Fn): On Error GoTo 0
If sBook Is Nothing Then Set sBook = Workbooks.Open(tBook.Path & "\" & Fn)
tBook.Activate
Sn = Sn_ALL(x)
'↑令Sn這字串變數是 第x變數索引號的Sn_ALL變數(陣列)值
For Each S In Split(Sn, "/")
    On Error Resume Next
    Set Sw = sBook.Sheets(S & "")
    Set tSht = tBook.Sheets(S & "")
    On Error GoTo 0
    If Sw Is Nothing Then MsgBox "原檔找不到〔" & S & "〕工作表!!!": GoTo s01
    If tSht Is Nothing Then MsgBox "本檔案找不到〔" & S & "〕工作表，請確認後再重新執行!!!": Exit Sub
    tSht.UsedRange.Clear
    Range(Sw.[A1], Sw.UsedRange).Copy tSht.[A1]
    Set Sw = Nothing: Set tSht = Nothing
s01: Next S
sBook.Close 0
tBook.Sheets(1).Select
Application.ScreenUpdating = True
End Sub

shuo1125

回復 6# Andy2483
Andy2483前輩好:
將資料放入陣列中執行，晚輩學藝不精無法想到這塊...
還勞煩幫忙註記解釋，謝謝您的指導!!

Andy2483

回復 7# shuo1125


    謝謝前輩回復
如果需要增加執行的活頁簿,在陣列裡增加就可以
Fn_ALL = Array([A2], [A3]): Sn_ALL = Array("A/B/C", "D/E/F")

請前輩常上論壇一起學習

shuo1125

回復 8# Andy2483
Andy2483前輩好:
這個基本概念我還是有的...謝謝提點!
我只能看看高手們的解答並試著理解，程度遠不夠與各位討論專業問題。