RCRG

　暱稱: RCRG滾奶滾企

帖子: 95
主題: 24
精華: 0
積分: 118
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
註冊時間: 2015-11-10
最後登錄: 2020-5-25

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2015-11-21 12:20 | 只看該作者

[發問] 如何能一鍵複製並新增多頁工作表?

一鍵複製並新增工作表.rar (14.15 KB)

有勞各位大大解答了！3Q。

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2015-11-21 15:22 | 只看該作者

回復 1# RCRG
試試看

Option Explicit
Sub Ex()
Dim xDay As Date, i As Date, x As Date
On Error Resume Next
AG:
Do
xDay = InputBox("輸入日期", "工作表日期", Date)
If Err > 0 Then Err.Clear: GoTo AG ' 日期格式錯誤:程式移到 AG 執行
x = MsgBox("確定日期為: " & Format(xDay, "Dddddd"), vbYesNoCancel, "工作表日期")
If x = vbCancel Then Exit Sub '取消鍵: 離開這程式
Loop Until x = vbYes '確定鍵: 離開這迴圈
On Error GoTo Er
Application.DisplayAlerts = False
For i = xDay To xDay + 15 * 2 Step 4 '間隔4天
For x = i To i + 1 '連續2天
Sheets("原始檔").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = Format(x, "Dddddd") '有這工作表日期程式或有錯誤
Next
Next
Application.DisplayAlerts = True
Exit Sub
Er: '處裡工作命名的錯誤
Sheets(Format(x, "Dddddd")).Delete
Resume '回到錯誤的程式碼
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

RCRG

　暱稱: RCRG滾奶滾企

中學生 Rank: 2

帖子: 95
主題: 24
精華: 0
積分: 118
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
註冊時間: 2015-11-10
最後登錄: 2020-5-25

3^#

發表於 2015-11-22 04:13 | 只看該作者

回復 2# GBKEE

答案完全沒問題可以使用喔！結果也完全符合我所需要的，真的是謝謝GBKEE大的幫忙了！

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

4^#

發表於 2015-11-22 10:50 | 只看該作者

Sub 新增工作表()
Dim X, j%, k%, SN, SH As Worksheet
Do
　　X = Application.InputBox("請輸入日期，如：2015/6/6 或 2015-6-5")
　　If X & "" = "False" Then Exit Sub
　　If IsDate(X) Then Exit Do
　　MsgBox "日期錯誤或未輸入，請重新輸入～～"
Loop
　
Application.DisplayAlerts = False
For j = 0 To 8
For k = 0 To 1
　　SN = Format(DateValue(X) + j * 4 + k, "yyyy-m-d")　'工作表名稱
　　On Error Resume Next
　　　　Set SH = Nothing: Set SH = Sheets(SN)　'檢查工作表是否存在
　　On Error GoTo 0
　　If SH Is Nothing Then　'若工作表不存在，複製一個重命名
　　　Sheets("原始檔").Copy after:=Sheets(Sheets.Count)
　　　ActiveSheet.Name = SN
　　End If
Next k
Next j
Sheets("複製新增工作表").Select
End Sub

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 刪除工作表()
Dim SH As Worksheet
Application.DisplayAlerts = False
For Each SH In Sheets
　　If IsDate(SH.Name) Then SH.Delete
Next
End Sub

TOP

RCRG

　暱稱: RCRG滾奶滾企

中學生 Rank: 2

帖子: 95
主題: 24
精華: 0
積分: 118
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
註冊時間: 2015-11-10
最後登錄: 2020-5-25

5^#

發表於 2015-11-24 11:54 | 只看該作者

回復 4# 准提部林

准大也出招了！還另外附送了工作表刪除，也非常謝謝您的答案唷！3Q

TOP

RCRG

　暱稱: RCRG滾奶滾企

中學生 Rank: 2

帖子: 95
主題: 24
精華: 0
積分: 118
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
註冊時間: 2015-11-10
最後登錄: 2020-5-25

6^#

發表於 2015-12-7 07:40 | 只看該作者

回復 4# 准提部林

請問准大，"刪除工作表" 能幫我先彈出是否確認刪除的視窗嗎? 不然怕手殘會按到誤刪...XD ，謝謝！

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

7^#

發表於 2015-12-7 10:04 | 只看該作者

回復 6# RCRG

If MsgBox("確認要刪除工作表嗎？", 4 + 32 + 256) = vbNo Then Exit Sub

＜參數一＞
0	只顯示 OK 按鈕。
1	顯示 OK 及 Cancel 按鈕。
2	顯示 Abort、 Retry 及 Ignore 按鈕。
3	顯示 Yes、No 及 Cancel 按鈕。
4	顯示 Yes 及 No 按鈕。
5	顯示 Retry 及 Cancel 按鈕。
＜參數二＞
16	顯示 Critical Message 圖示。
32	顯示 Warning Query 圖示。
48	顯示 Warning Message 圖示。
64	顯示 Information Message 圖示。
＜參數三＞
0	第一個按鈕是預設值。
256	第二個按鈕是預設值。
512	第三個按鈕是預設值。
768	第四個按鈕是預設值。

TOP

RCRG

　暱稱: RCRG滾奶滾企

中學生 Rank: 2

帖子: 95
主題: 24
精華: 0
積分: 118
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
註冊時間: 2015-11-10
最後登錄: 2020-5-25

8^#

發表於 2015-12-7 23:00 | 只看該作者

回復 7# 准提部林

謝謝准大詳細的說明與顏色區分。

TOP