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

oao

1. Sub 報表()
   
2. 
   
3.     Dim Wb As Workbook
   
4.     Dim Thesou As String
   
5.     Application.ScreenUpdating = False
   
6.     Thesou = ThisWorkbook.Path & "\報表範本.xlsx"
   
7.     Set Wb = GetObject(Thesou)
   
8.     Dim X As Integer
   
9.      X = 2
   
10.     Do
    
11.         Wb.Sheets(1).Copy after:=ThisWorkbook.Sheets(Sheets.Count)
    
12.         ActiveSheet.Name = Sheets("Shall").Cells(X, 1) & Sheets("Shall").Cells(X, 2)
    
13.         X = X + 1
    
14.     Loop Until Sheets("Shall").Cells(X, 1) = "" Or Sheets("Shall").Cells(X, 2) = ""
    
15.     Wb.Close False
    
16.     Set Wb = Nothing
    
17.     Application.ScreenUpdating = True
    
18. 
    
19. End Sub

複製代碼

在活頁簿總報表.xlsx的Shall工作表，欄A和欄B分別是商品編號和商品名稱，
要把同資料夾活頁簿報表範本.xlsx的Sheets(1)複製回活頁簿總報表.xlsx，
並分別建立名稱為商品編號+商品名稱的n個工作表
因我是大菜鳥，所以程式碼又臭又長，目前只能反覆複製報表範本.xlsx的Sheets(1)工作表貼回總報表.xlsx
懇請高手們賜教更有效率的寫法，感激不盡！謝謝！

luhpro

回復 1# oao
以下程式不可重複執行(會發生 SheetName 重複的錯誤), 這裡沒有設定按鈕或觸發此程序的機制, 建議以單部執行來觀察運作情形.

1. Sub CrtSheet()
   
2.   Dim lRow&
   
3.   Dim sStr$
   
4.   Dim rSou As Range, rTar As Range
   
5. 
   
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)

下載次數: 8

2013-11-15 22:27

' 以下是我的使用 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)

oao

回復 2# sunnyso
A.rar (17.01 KB)

簡易附件
下載次數: 9

2013-11-15 22:58

附上附件，還請賜教，謝謝！

oao

回復 3# luhpro
感謝指導，我先下載大大的附件參考，非常謝謝！

stillfish00

回復 1# oao
試試有沒有比較快

1. Sub 報表()
   
2.     Dim x As Long
   
3.     Dim Thesou As String
   
4.     Thesou = ThisWorkbook.Path & "\報表範本.xlsx"   '範本只含一個工作表
   
5.         
   
6.     Application.ScreenUpdating = False
   
7.     With Sheets("Shall")
   
8.         For x = .[A1].End(xlDown).Row To 2 Step -1
   
9.             Sheets.Add(After:=Sheets(1), Type:=Thesou).Name = .Cells(x, 1) & .Cells(x, 2)
   
10.         Next
    
11.     End With
    
12.     Application.ScreenUpdating = True
    
13. End Sub

複製代碼

luhpro

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

複製代碼

stillfish00

在 Type:=Thesou 處會發生錯誤.
luhpro 發表於 2013-11-16 07:15

Excel2003 範本另存新檔為 "報表範本.xlt" 看看

oao

回復 8# stillfish00
很感謝，測試後速度快多了，謝謝stillfish00大教了在下寶貴的一課，感恩！