返回列表 上一主題 發帖

[發問] 請教不同活頁簿間的工作表複製

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
1# 跳轉到 »
發表於 2013-11-15 22:27 | 顯示全部帖子
本帖最後由 luhpro 於 2013-11-15 22:30 編輯

回復 1# oao
以下程式不可重複執行(會發生 SheetName 重複的錯誤), 這裡沒有設定按鈕或觸發此程序的機制, 建議以單部執行來觀察運作情形.
  1. Sub CrtSheet()
  2.   Dim lRow&
  3.   Dim sStr$
  4.   Dim rSou As Range, rTar As Range

  6.   With Workbooks.Open(ThisWorkbook.Path & "\報表範本.xls")
  7.     Set rSou = .Sheets("Sheet1").[A1] ' 來源
  8.   End With
  9.   Set rTar = ThisWorkbook.Sheets("Sheet1").[A1] ' 目的
  10.   
  11.   With rTar.Parent ' 只 Copy 1 個 Sheet, 之後改以此 Sheet 做母版
  12.     lRow = 2
  13.     sStr = .Cells(lRow, 1) & "-" & .Cells(lRow, 2)
  14.     rSou.Parent.Cells.Copy
  15.     .Activate
  16.     With ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
  17.       With .[A1]
  18.         .PasteSpecial
  19.         .Select ' 避免整個 Sheet 被 Select 的情形
  20.       End With
  21.       .Name = sStr ' 改名
  22.     End With
  23. Application.DisplayAlerts = False ' 關掉系統確認是否放棄大量複製資料的詢問訊息
  24.     rSou.Parent.Parent.Close False ' 關閉範例檔案
  25. Application.DisplayAlerts = True
  26.   
  27.     Set rSou = Sheets(sStr).[A1] ' 產生其他 Sheet
  28.     lRow = 3
  29.     Do While .Cells(lRow, 1) <> ""
  30.       sStr = .Cells(lRow, 1) & "-" & .Cells(lRow, 2)
  31.       rSou.Parent.Cells.Copy
  32.       .Activate
  33.       With ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
  34.         With .[A1]
  35.           .PasteSpecial
  36.           .Select
  37.         End With
  38.         .Name = sStr
  39.       End With
  40.       lRow = lRow + 1
  41.     Loop
  42.   End With
  43. End Sub
複製代碼
不同活頁簿間的工作表複製.zip (9.15 KB)
' 以下是我的使用 Excel VBA 幾年後的觀點 : (只使用過 Excel 2000 與 Excel 2003)
' Excel VBA 中只能 Dim Range 不能 Dim Sheet (對應單一 Sheet, 且適用任一 Sheet), 只能 Dim WorkSheet
' 這裡不採用 WorkSheet, 因為Worksheet 只能對應到目前的 Sheet(Active 的), 不論你括弧內放什麼SheetName, 甚至事先 Set 過的, 用時都是指向同一個 Sheet
' 也不採用 Sheetx , 因為不論是 Sheet1, Sheet2, Sheet3... 都很難用, Sheet1 只能用在 Sheets(1), 用在其他 Sheet 就會發生錯誤
' 所以我改用 Range.Parent 來指向特定的 Sheet (好處是只要不是用 Work相關指令<WorkSheet...> 或是 Select 就不用事先 Activate, 照樣對應到事先定義好的 Sheet)

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
2#
發表於 2013-11-16 07:15 | 顯示全部帖子
回復 6# stillfish00
在 Type:=Thesou 處會發生錯誤.

參照 6# 又改出兩種方式 :
  1. Sub 報表()
  2.     Dim x As Long
  3.     Dim wsSou As Worksheet
  4.     Dim Thesou As String
  5.     Set wsSou = Workbooks.Open(ThisWorkbook.Path & "\報表範本.xls").Sheets(1)   '範本只含一個工作表
  6.         
  7.     Application.ScreenUpdating = False
  8.     With ThisWorkbook.Sheets("Sheet1")
  9.         For x = .[A1].End(xlDown).Row To 2 Step -1
  10.             wsSou.Copy After:=.[A1].Parent
  11.              ActiveSheet.Name = .Cells(x, 1) & .Cells(x, 2)
  12.         Next
  13.     End With
  14.     Application.ScreenUpdating = True
  15. End Sub
複製代碼
  1. Sub 報表2()
  2.     Dim x As Long
  3.     Dim rSou As Range, rTar As Range
  4.     Dim Thesou As String
  5.     Set rTar = ThisWorkbook.Sheets("Sheet1").[A1]
  6.     Set rSou = Workbooks.Open(ThisWorkbook.Path & "\報表範本.xls").Sheets("Sheet1").[A1]   '範本只含一個工作表
  7.         
  8.     Application.ScreenUpdating = False
  9.     With rTar.Parent
  10.         For x = .[A1].End(xlDown).Row To 2 Step -1
  11.             rSou.Parent.Copy After:=.Parent.Sheets(1)
  12.             ActiveSheet.Name = .Cells(x, 1) & .Cells(x, 2)
  13.         Next
  14.     End With
  15.     Application.ScreenUpdating = True
  16. End Sub
複製代碼

TOP

        靜思自在 : 【行善要及時】行善要及時，功德要持續。如燒開水一般，未燒開之前千萬不要停熄火候，否則重來就太費事了。
返回列表 上一主題