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

RCRG

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

下載次數: 11

2015-11-21 12:20

下載 (28.92 KB)

2015-11-21 12:19

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

RCRG

回復 7# 准提部林


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

准提部林

回復 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	第四個按鈕是預設值。

RCRG

回復 4# 准提部林


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

RCRG

回復 4# 准提部林


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

准提部林

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

RCRG

回復 2# GBKEE


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

GBKEE

回復 1# RCRG
試試看

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

複製代碼