- 帖子
- 41
- 主題
- 7
- 精華
- 0
- 積分
- 52
- 點名
- 0
- 作業系統
- Windows10
- 軟體版本
- 2019
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2017-11-28
- 最後登錄
- 2025-3-4
|
本帖最後由 edmondsforum 於 2020-6-30 01:08 編輯
回復 13# n7822123
萬般的感謝龍大的回覆!!!!!
我根據龍大提供的程式碼，並依照你意思刪除我不需要的部分
Sub test0624()
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual '停用自動重算
xPH = ThisWorkbook.Path & "\"
On Error Resume Next
Set xS = Sheets("週報表")
xWeek = InputBox("請輸入第""?""週")
xlsName = xPH & "第1~" & xWeek & "週.xlsx"
'B結果：一個檔案。(第1~5週.XLSX) 裡頭有5個工作表
With Workbooks.Add
sh_Cnt = .Sheets.Count
For sh = 1 To xWeek
xS.Activate
xS.Copy After:=Sheets(Sheets.Count)
Set xName = ActiveSheet
ActiveSheet.Name = "第" & sh & "週"
With xName.UsedRange
.Calculate
.Value = .Value
End With
xName.Copy After:=.Sheets(.Sheets.Count) '注Sheets前面有 "." 是複製到新的活頁簿
xName.Delete
Next sh
'刪除原本空白表格
For sh = 1 To sh_Cnt: .Sheets(1).Delete: Next
'存檔關閉
.SaveAs xlsName
.Close True
End With
'A結果：分別產生5個檔案。( 第1週.XLSX 第2週.XLSX 第3週.XLSX 第4週.XLSX 第5週.XLSX)
'這段基本上可已與上面那段合併寫，但程式會不好閱讀，為了讓你看懂，先拆開寫給你
'因為我的週報表F1 與 G1 都是錯誤值，檔名的日期我先自己定義，你再自己修改!
With Workbooks.Open(xlsName)
For sh = 1 To .Sheets.Count
Strday = .Sheets(sh).[F1] '你的日期開始，請自行打開測試
Endday = .Sheets(sh).[H1] '你的日期結束，請自行打開測試
xlsName = "(" & .Sheets(sh).Name & ").xlsx"
xlsName = xPH & Strday & "~" & Endday & xlsName
.Sheets(sh).Copy
ActiveWorkbook.SaveAs xlsName
ActiveWorkbook.Close True
Next
.Close False
End With
Set xS = Nothing
Set xName = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic '啟用自動重算
End Sub
我發現如果我原本的這個 xS = Sheets("週報表") 裡面的F1 跟 H1 是純文字的話，
就會成功依照內容令存檔名，但是裡面是那個有函數公式的話
他就會跑出叫我另存的視窗耶。
P.S.我已經把IFS函數改掉了
我能跟龍大請教說，你寫的這個函數意思
是先根據我的條件先行產生一個檔案 ( xPH & "第1~" & xWeek & "週.xlsx" )
並從這個檔案分別另存出來的嗎?
因為要是這樣的話，照理說不會出現叫我另存吧，代表他找不到裡面的值呢?
我在想照以下的步驟嘗試寫程式碼，但然後就卡住了(在不先行產生 xPH & "第1~" & xWeek & "週.xlsx" 情況下)
假設我輸入3 ，
先在原本的檔案 產生三個工作表， 第一週、第二週、第三週
三個工作表裡面的值也都轉換成純文字了
在批量另存，並分別根據原本檔案的 第一週、第二週、第三週的儲存格 作為檔名
在刪掉原本的檔案的三個工作表。
Sub Create01() '批量複製'
Dim xS As Worksheet, xName As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual '停用自動重算
xPH$ = ThisWorkbook.Path & "\"
Set xS = Sheets("週報表")
xWeek% = InputBox("請輸入第1週∼第""?""週") 'A結果：分別產生5個檔案。( 第1週.XLSX 第2週.XLSX 第3週.XLSX 第4週.XLSX 第5週.XLSX)
For i = 1 To xWeek
xS.Copy After:=Sheets(Sheets.Count)
Set xName = ActiveSheet
xName.Name = "第" & i & "週"
With xName.UsedRange
.Calculate '重算
.Value = .Value
End With
Strday = ActiveSheet.Range("F1")
xName.Copy
With ActiveWorkbook
.SaveAs xPH & Strday & i & "週.xlsx", CreateBackup:=False
.Close True
End With
xName.Delete
Set xName = Nothing
Next
Set xS = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic '啟用自動重算
End Sub
跑這樣還是錯
請原諒小弟的愚蠢
我真的不會把這串
With Workbooks.Open(xlsName)
For sh = 1 To .Sheets.Count
Strday = .Sheets(sh).[F1] '你的日期開始，請自行打開測試
Endday = .Sheets(sh).[H1] '你的日期結束，請自行打開測試
xlsName = "(" & .Sheets(sh).Name & ").xlsx"
xlsName = xPH & Strday & "~" & Endday & xlsName
.Sheets(sh).Copy
ActiveWorkbook.SaveAs xlsName
ActiveWorkbook.Close True
Next
.Close False
End With
帶入進去....
再拜託龍大檢視了
 TEST-0630.zip (331.38 KB)
|
|
發表於 2020-6-23 18:05
| 
