Board logo

標題: [發問] 請教不同活頁簿間的工作表複製 [打印本頁]
作者: oao    時間: 2013-11-15 17:14     標題: 請教不同活頁簿間的工作表複製

  1. Sub 報表()

  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

  19. End Sub
複製代碼

在活頁簿總報表.xlsx的Shall工作表，欄A和欄B分別是商品編號和商品名稱，
要把同資料夾活頁簿報表範本.xlsx的Sheets(1)複製回活頁簿總報表.xlsx，
並分別建立名稱為商品編號+商品名稱的n個工作表
因我是大菜鳥，所以程式碼又臭又長，目前只能反覆複製報表範本.xlsx的Sheets(1)工作表貼回總報表.xlsx
懇請高手們賜教更有效率的寫法，感激不盡！謝謝！
作者: luhpro    時間: 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
複製代碼
[attach]16714[/attach]
' 以下是我的使用 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    時間: 2013-11-15 23:00

回復 2# sunnyso
[attach]16717[/attach]
附上附件，還請賜教，謝謝！
作者: oao    時間: 2013-11-15 23:09

回復 3# luhpro
感謝指導，我先下載大大的附件參考，非常謝謝！
作者: stillfish00    時間: 2013-11-15 23:48

本帖最後由 stillfish00 於 2013-11-16 00:00 編輯

回復 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    時間: 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
複製代碼
作者: stillfish00    時間: 2013-11-16 10:37

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


Excel2003 範本另存新檔為 "報表範本.xlt" 看看
作者: oao    時間: 2013-11-16 18:26

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)