- 帖子
- 835
- 主題
- 6
- 精華
- 0
- 積分
- 915
- 點名
- 16
- 作業系統
- Win 10,7
- 軟體版本
- 2019,2013,2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2010-5-3
- 最後登錄
- 2024-11-14
|
2#
發表於 2013-11-15 22:27
| 只看該作者
本帖最後由 luhpro 於 2013-11-15 22:30 編輯
回復 1# oao
以下程式不可重複執行(會發生 SheetName 重複的錯誤), 這裡沒有設定按鈕或觸發此程序的機制, 建議以單部執行來觀察運作情形.- Sub CrtSheet()
- Dim lRow&
- Dim sStr$
- Dim rSou As Range, rTar As Range
-
- With Workbooks.Open(ThisWorkbook.Path & "\報表範本.xls")
- Set rSou = .Sheets("Sheet1").[A1] ' 來源
- End With
- Set rTar = ThisWorkbook.Sheets("Sheet1").[A1] ' 目的
-
- With rTar.Parent ' 只 Copy 1 個 Sheet, 之後改以此 Sheet 做母版
- lRow = 2
- sStr = .Cells(lRow, 1) & "-" & .Cells(lRow, 2)
- rSou.Parent.Cells.Copy
- .Activate
- With ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
- With .[A1]
- .PasteSpecial
- .Select ' 避免整個 Sheet 被 Select 的情形
- End With
- .Name = sStr ' 改名
- End With
- Application.DisplayAlerts = False ' 關掉系統確認是否放棄大量複製資料的詢問訊息
- rSou.Parent.Parent.Close False ' 關閉範例檔案
- Application.DisplayAlerts = True
-
- Set rSou = Sheets(sStr).[A1] ' 產生其他 Sheet
- lRow = 3
- Do While .Cells(lRow, 1) <> ""
- sStr = .Cells(lRow, 1) & "-" & .Cells(lRow, 2)
- rSou.Parent.Cells.Copy
- .Activate
- With ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
- With .[A1]
- .PasteSpecial
- .Select
- End With
- .Name = sStr
- End With
- lRow = lRow + 1
- Loop
- End With
- 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) |
|
