麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] VBA修改 : 複製有函數的工作表，並另存到新的工作簿 [打印本頁]

作者: edmondsforum 時間: 2020-6-23 18:05 標題: VBA修改 : 複製有函數的工作表，並另存到新的工作簿

小弟，有一個檔案叫做 "週、月報表.xlsm"
裡面有工作表分別為：週報表、工作進度等兩個。
週報表裡面有個函數為 =sheetname ，這是為了我方便根據"工作進度"使用VLOOKUP 抓出數據。
所以我只要複製週報表，並另名為"第一週" 他就會去抓"工作進度"合乎的內容
因此，我參照版上寫了以下VBA

Sub test3()
Dim I As Long
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
xPH = ThisWorkbook.Path & "\"
On Error Resume Next
Application.ScreenUpdating = False
Set xS = Sheets("週報表")
xWeek = InputBox("請輸入第""?""週")
xS.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "第" & xWeek & "週"
Set xName = ActiveSheet
xName.Copy
Application.DisplayAlerts = False
With xName.UsedRange
.Value = .Value
End With
With ActiveWorkbook
ActiveSheet.Name = "第" & xWeek & "週"
.SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
.Close
End With
Application.ScreenUpdating = True
End Sub

複製代碼

主要目的就是可以讓我輸入第"幾"週，就會產生一個第"幾"週工作表，並先讓他跑一下函數後( 例：VLOOKUP..等)
然後以純貼上值的方式取代
所以寫這個

With xName.UsedRange
.Value = .Value
End With

複製代碼

但是想把他另存到目前工作簿("週、月報表.xlsm")的旁邊(同資料夾下)
所以參考別人寫了

With ActiveWorkbook
ActiveSheet.Name = "第" & xWeek & "週"
.SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
.Close
End With

複製代碼

但另存的檔案內容還是參照到"週報表"函數......甚至條件不足造成亂碼，
不知道怎麼把它寫成，另存之後也是以純貼上值的方式........
再請求各位大神指點迷津.....拜託了

作者: edmondsforum 時間: 2020-6-23 18:25

我補充說明一下
假設我複製成功後,且另存新的檔案
那麼原先舊的檔案不是會產生工作表嗎
他能移除嗎？
或者是有什麼方式
先複製根據名稱跑函數，然後直接產生到新的檔案並以純值方式貼上。
不會而外在舊的檔案產生新工作表
不知道這樣表達各位大神能了解嗎

作者: n7822123 時間: 2020-6-24 00:41

本帖最後由 n7822123 於 2020-6-24 00:50 編輯

回復 1# edmondsforum

沒檔案測試........只能看你的程式在腦海中演練

不過確實讓我看到問題，你工作表copy的時候還是有公式的

所以要調換順序，先寫

With xName.UsedRange
.Value = .Value
End With

再寫

xName.Copy

去掉公式再複製工作表基本上就沒問題了

我補充說明一下
假設我複製成功後,且另存新的檔案
那麼原先舊的檔案不是會產生工作表嗎
他能移除嗎？

在 Application.ScreenUpdating = True 這行程式前面寫刪除工作表，應該就可以了

xName.delete

如果執行有錯的話，請附上檔案來看看吧，我幾乎是盲寫的

作者: n7822123 時間: 2020-6-24 01:04

本帖最後由 n7822123 於 2020-6-24 01:13 編輯

回復 3# n7822123

避免你看不懂我在講什麼，產生雞同鴨講，還是改給你，你測試看看

Sub test3()

Dim I As Long
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
xPH = ThisWorkbook.Path & "\"
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xS = Sheets("週報表")
xWeek = InputBox("請輸入第""?""週")
xS.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "第" & xWeek & "週"
Set xName = ActiveSheet
With xName.UsedRange
      .Value = .Value
End With
xName.Copy
With ActiveWorkbook
   ActiveSheet.Name = "第" & xWeek & "週"
   .SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
   .Close
End With
xName.Delete
Application.ScreenUpdating = True

End Sub

作者: edmondsforum 時間: 2020-6-24 08:37

回復 4# n7822123
抱歉果然真的沒檔案會讓人很難理解@@
請諒解，我再度述說一次
1.假設我執行VBA了，輸入週數了
[attach]32206[/attach]

2.輸入3之後，會產生"第3周"，此時地這個檔案的第3週
事先根據第3週去跑VLOOKUP後，以純值貼上。
[attach]32207[/attach]

3.這邊我提個問題，為什麼跑完之後，我這邊的"週報表"的公式 =SHEETNAME 都暫時會以第3週呈現?
但只要點兩下就會正常，有辦法讓他自動更新嗎?

4.接著2，跑完之後，同時檔案旁邊也會產生"第3週"的檔案，但是未開啟的(大大教我改寫的方式會使他同時開啟)
因為將來會有批量產生的問題
[attach]32209[/attach]

5.然後我點開產生另一個檔案的"第三週" 仍然還是有公式存在
[attach]32210[/attach]

6.以上就是我的問題，目前檔案裡面有三個程式碼
[attach]32211[/attach]
"工作進度"目前使用的是 Create1 Create3
目前是以test3再跑，如果成功，會分別應用在 Create1 Create3
如果可以再請大大幫忙一起改寫.....一個獨立複製一個是批量複製的

檔案供參考
[attach]32212[/attach]

作者: jcchiang 時間: 2020-6-24 09:17

回復 5# edmondsforum

With xName.UsedRange
.Value = .Value
End With
改為
With ActiveSheet.UsedRange
.Value = .Value
End With

因為xName被設定為原檔案的Sheet了,所以是將原檔案的改為值

作者: edmondsforum 時間: 2020-6-24 10:16

回復 6# jcchiang
謝謝大大
改成這樣之後，後面在加一個 xName.Delete 確實能創造我要的
附上修改後的

Sub test3()
Dim I As Long
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
xPH = ThisWorkbook.Path & "\"
On Error Resume Next
Application.ScreenUpdating = False
Set xS = Sheets("週報表")
xWeek = InputBox("請輸入第""?""週")
xS.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "第" & xWeek & "週"
Set xName = ActiveSheet
xName.Copy
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
.Value = .Value
End With
With ActiveWorkbook
ActiveSheet.Name = "第" & xWeek & "週"
.SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
.Close
End With
xName.Delete
Application.ScreenUpdating = True
End Sub

複製代碼

但我這邊有三個問題

1.為什麼只要我執行VBA 會產生這個 #N/A 雖然點進去兩下就會正常
擔心是不是哪個程式碼寫錯?
[attach]32215[/attach]

2.我應用相同的方式把它寫在批量上面，但...就卡住了批量複製是：Sub Create1() '批量複製'
會死當哈哈

3.請問我另存的檔案名稱，可不可以根據他的日期目前的週數和日期命名呢?
例如，第三週  ，日期是：自民國 109 年 3 月 5 日至民國 109 年 3 月 11 日 (以週計)
檔案名就會顯示：1090305~1090311(第三週).xlsx
備註，那個109年03月05日是在F1  ， 109年03月11日是在H1
[attach]32216[/attach]

[attach]32217[/attach]

作者: edmondsforum 時間: 2020-6-24 10:24

回復 7# edmondsforum

對不起，能麻煩幫我寫兩個針對批量複製的嗎?
可以分別寫兩個不同狀況，另存的程式碼嗎

假設我輸入5
1. 第1週.XLSX 第2週.XLSX 第3週.XLSX 第4週.XLSX 第5週.XLSX 5個檔案
2 第1~5週.XLSX (裡面有5個工作表哦)
再拜託各位亣大了:$

作者: n7822123 時間: 2020-6-24 11:58

本帖最後由 n7822123 於 2020-6-24 12:04 編輯

回復 5# edmondsforum

xName 是從週報表複製出來的工作表 (Ex:第三週)

先把xName 去公式再複製出活頁簿，就不會有公式

最後再把xName刪掉，就是我3樓與4樓跟你講的寫法

感覺你5樓與7樓的回答，連試我的程式都沒有嚐試過

那我還有必要再回答下去嗎?

作者: edmondsforum 時間: 2020-6-24 12:40

本帖最後由 edmondsforum 於 2020-6-24 12:43 編輯

回復 9# n7822123
對不起龍哥，請原諒我的疏忽
是我放錯位置...導致還是跑出公式，但確實你的方式是成功的

Sub Create3() '獨立複製'
Dim I As Long
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
xPH = ThisWorkbook.Path & "\"
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xS = Sheets("週報表")
xWeek = InputBox("請輸入第""?""週")
xS.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "第" & xWeek & "週"
Set xName = ActiveSheet
With ActiveSheet.UsedRange
.Value = .Value
End With
xName.Copy
With ActiveWorkbook
ActiveSheet.Name = "第" & xWeek & "週"
.SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
.Close
End With
xName.Delete
Application.ScreenUpdating = True
End Sub

複製代碼

能拜託大大幫我檢核批量的嗎拜託拜託

Sub Create1() '批量複製'
Dim I As Long
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
xPH = ThisWorkbook.Path & "\"
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xS = Sheets("週報表")
xWeek = InputBox("請輸入第1週～第""?""週")
For I = 1 To xWeek
xSt.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "第" & I & "週"
Set xName = ActiveSheet
With ActiveSheet.UsedRange
.Value = .Value
End With
xName.Copy
With ActiveWorkbook
ActiveSheet.Name = "第" & xWeek & "週"
.SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
.Close
End With
Next
xName.Delete
Application.ScreenUpdating = True
End Sub

複製代碼

另外請教，

1.是不是得新增某個程式碼，才能讓原本的"週報表"不會產生 #N/A 呢

2.另存的檔案名稱，可不可以根據他的日期目前的週數和日期命名呢?
例如，第三週  ，日期是：自民國 109 年 3 月 5 日至民國 109 年 3 月 11 日 (以週計)
檔案名就會顯示：1090305~1090311(第三週).xlsx
備註，那個109年03月05日是在F1  ， 109年03月11日是在H1

3.假如龍大成功寫出，批量的，能幫我分別寫出另存的時候兩種結果嗎?
假設輸入5
A結果：分別產生5個檔案。( 第1週.XLSX 第2週.XLSX  第3週.XLSX  第4週.XLSX  第5週.XLSX)
B結果：一個檔案。(第1~5週.XLSX) 裡頭有5個工作表

再拜託龍大了，我下次絕對不會目小了，對不起:Q

[attach]32222[/attach]

作者: jcchiang 時間: 2020-6-24 17:38

回復 10# edmondsforum
for...next變數是I,不是xWeek

With ActiveWorkbook
                        ActiveSheet.Name = "第" & I & "週"
                        .SaveAs xPH & "第" & I & "週.xlsx", CreateBackup:=False
                        .Close
                     End With

作者: edmondsforum 時間: 2020-6-24 18:03

回復 11# jcchiang
啊謝謝大大的提醒
重新改成

Sub Create1() '批量複製'
Dim I As Long
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
xPH = ThisWorkbook.Path & "\"
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xS = Sheets("週報表")
xWeek = InputBox("請輸入第1週～第""?""週")
For I = 1 To xWeek
xSt.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "第" & I & "週"
Set xName = ActiveSheet
With ActiveSheet.UsedRange
.Value = .Value
End With
xName.Copy
With ActiveWorkbook
ActiveSheet.Name = "第" & I & "週"
.SaveAs xPH & "第" & I & "週.xlsx", CreateBackup:=False
.Close
End With
Next
xName.Delete
Application.ScreenUpdating = True
End Sub

複製代碼

雖然沒卡住，但是假設我輸入 3 產生，第1週.xlsx 第2週.xlsx 第3週.xlsx
第1週內容是OK的，但其餘的全部都是跟第1週一樣的內容...
而且他反而把我的 "週報表" 工作表移除掉了...求解

作者: n7822123 時間: 2020-6-25 01:21

本帖最後由 n7822123 於 2020-6-25 01:29 編輯

回復 10# edmondsforum

1.是不是得新增某個程式碼，才能讓原本的"週報表"不會產生 #N/A 呢

我的Excel版本是舊的2007版，沒有IFS函數
所以工作進度表格的G3欄位我看到的是錯誤值
連帶影響'工作進度'的F整欄、'週報表'的F1、F1、H1、D4、D5看到的都是錯誤值
所以這部分我沒辦法幫你檢查函數的正確性

2.另存的檔案名稱，可不可以根據他的日期目前的週數和日期命名呢?
例如，第三週  ，日期是：自民國 109 年 3 月 5 日至民國 109 年 3 月 11 日 (以週計)
檔案名就會顯示：1090305~1090311(第三週).xlsx
備註，那個109年03月05日是在F1  ， 109年03月11日是在H1

同為上面問題，沒有IFS函數，我看到的F1與H1是錯誤值，
我自己寫個日期區間，你再自己改成你要的檔名

3.假如龍大成功寫出，批量的，能幫我分別寫出另存的時候兩種結果嗎?
假設輸入5
A結果：分別產生5個檔案。( 第1週.XLSX 第2週.XLSX  第3週.XLSX  第4週.XLSX  第5週.XLSX)
B結果：一個檔案。(第1~5週.XLSX) 裡頭有5個工作表

這部分已完成，沒什麼問題，為了方便你閱讀，A結果與B結果我分段寫

以下是程式部分

Sub test0624()
Dim xWeek As Integer
Dim xS As Worksheet
Dim xPH$
Dim 年份 As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual       '停用自動重算
年份 = 2020    '判斷每週的起始、每週的結束日期用
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 = Format(週始日(年份, sh), "emmdd")             '利用自定函數抓該週次的起使日期(阿龍Test用)
Endday = Format(週始日(年份, sh) + 6, "emmdd")    '利用自定函數抓該週次的結束日期(阿龍Test用)
'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

這段副函數是我自己定的，因為我看到的F1、G1是錯誤值，
所以你把檔名改掉之後，這段副函數砍掉也沒關係

Function 週始日(ByVal 西元 As Integer, ByVal 週次 As Integer) As Date
Dim Day1 As Date, 週始1 As Date
Day1 = DateSerial(2020, 1, 1)
週始1 = Day1 - Weekday(Day1) + 1
Dayadd = (週次 - 1) * 7
週始日 = 週始1 + Dayadd
End Function

檔案如下，方便舊版Excel的人也可以打開來看，我存2個檔案(新版 & 舊版)
明天一整天要出去玩，如果還有任何問題，只能等看看其他人回覆了，
我最快6/26晚上才能回覆

[attach]32226[/attach]

作者: n7822123 時間: 2020-6-25 07:44

本帖最後由 n7822123 於 2020-6-25 07:48 編輯

回復 12# edmondsforum

出門前看了一下，你好像要分兩個程序，用兩個按鈕控制

所以我把程式分開如下

第一個程序 (產生多個檔案)

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
xName.Copy
With ActiveWorkbook
      .SaveAs xPH & "第" & 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

第二個程序 (產生1個檔案，多工作表)

Sub Create02() '獨立複製'
Dim xS As Worksheet, xName As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual       '停用自動重算
xPH$ = ThisWorkbook.Path & "\"
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
      xName.Name = "第" & sh & "週"
      With xName.UsedRange
         .Calculate    '重算
         .Value = .Value
      End With
      xName.Copy After:=.Sheets(.Sheets.Count) '注Sheets前面有 "." 是複製到新的活頁簿
      xName.Delete
      Set xName = Nothing
Next sh
'刪除原本空白表格
For sh = 1 To sh_Cnt: .Sheets(1).Delete: Next
'存檔關閉
.SaveAs xlsName
.Close True
End With
Set xS = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic    '啟用自動重算
End Sub

你的工作表函數運算量太大........很容易死當

所以我執行程式過程中把函數自動重算關閉

建議你瘦身一下，減少函數計算量

出門了，掰掰

作者: 准提部林 時間: 2020-6-25 11:08

Sub 轉存()
Dim xSht As Worksheet, xPH$, NN, SName$, i&
Set xSht = Sheets("週報表")
xPH = ThisWorkbook.Path & "\"
For i = 1 To 1 '1至第?週, 自己搞定
SName = "第" & i & "週.xls"
xSht.Copy
With ActiveWorkbook
      With .Sheets(1).UsedRange: .Value = .Value: End With
      For Each NN In .Names '被帶過來的小孩--定義名稱--刪除
         If InStr(NN.Name, "Print_") = 0 Then NN.Delete '除了Print相關的, 餘刪除
      Next
      .SaveAs Filename:=xPH & SName, CreateBackup:=False
      .Close 0
End With
Next i
End Sub

=============================

作者: edmondsforum 時間: 2020-6-30 01:07

本帖最後由 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

帶入進去....

再拜託龍大檢視了

[attach]32241[/attach]

作者: n7822123 時間: 2020-6-30 02:50

本帖最後由 n7822123 於 2020-6-30 02:57 編輯

回復 16# edmondsforum

如果純文字可以，公式不行，那因該是少個屬性而已

因為電腦不知道你是要用公式當檔名還是公式的值當檔名

我還沒測，要睡了，你的檔案光是開起來就要好久~

我明天找時間試，你也可以先測看看，是不是多個".Value"

就沒問題了，程式如下

Strday = .Sheets(sh).[F1].Value '你的日期開始，請自行打開測試
Endday = .Sheets(sh).[H1].Value '你的日期結束，請自行打開測試

作者: n7822123 時間: 2020-6-30 03:19

本帖最後由 n7822123 於 2020-6-30 03:31 編輯

回復 16# edmondsforum

剛剛測一下，發現原因了~~

檔案名稱不能包含 "/" 字元，而你的F1、G1的儲存格格式是 "e/m/d"

所以修改一下輸出檔名的日期格式就沒問題了~~(儲存格格式不用改)

跟.Value沒關係，果然有些東西還是要檔案測才知道問題!

如果是之前的檔案F1、G1在我看來是錯誤值，那我就更不會發現這問題了~~

所以你們發問一定要附上檔案阿~~不然回答者就跟瞎子摸象沒兩樣

Strday = Format(.Sheets(sh).[F1], "emmdd") '你的日期開始 [F1]
Endday = Format(.Sheets(sh).[H1], "emmdd") '你的日期結束 [H1]

[attach]32242[/attach]

作者: edmondsforum 時間: 2020-6-30 11:16

回復 18# n7822123

謝謝龍大的點醒，原來是格式問題，礙於我自己的需求
我是希望能呈現民國，所以我另外透過 =TEXT(F1,"eemmdd") 等方式
然後再把他指定到其他儲存格就可以成功

   Strday = Format(Sheets(sh).[I1]
   Endday = Format(Sheets(sh).[K1]

目前就差最後一大步了，因為我不想要先產生 B結果
所以我還是嘗試把他寫進去

我有測試我輸入3時候，他只會產生第1週.xlsx  第2週.xlsx 和一個 ~(工作表1).xlsx

Sub test0630()

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("請輸入第""?""週")

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)
xName.Delete

   Strday = Format(Sheets(sh).[I1])
   Endday = Format(Sheets(sh).[K1])

   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

為什麼我已經輸入3 會跑不出第三週呢真奇怪....

再麻煩龍大看一下附件

[attach]32243[/attach]

作者: n7822123 時間: 2020-6-30 12:05

本帖最後由 n7822123 於 2020-6-30 12:07 編輯

回復 19# edmondsforum

要改程式要看得懂前後的程式再改............

程式前後是有關聯的，如果不需要結果B

不用寫那麼複雜，直接複製工作表另存活頁簿就好了~

直接簡化程式給你

Sub test0630_1()
Dim xWeek As Integer
Dim xPH$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual       '停用自動重算
xPH = ThisWorkbook.Path & "\"
xWeek = InputBox("請輸入第""?""週")
  For sh = 1 To xWeek
Sheets("週報表").Copy
With ActiveSheet
   .Name = "第" & sh & "週"
   Strday = Format(.[I1])
   Endday = Format(.[K1])
   With .UsedRange
      .Calculate
      .Value = .Value
   End With
   xlsName = xPH & Strday & "~" & Endday & "(" & .Name & ").xlsx"    '請問為什麼需要這串呢? -抓工作表 "(第X週)" 當做檔名
   .Parent.SaveAs xlsName
   .Parent.Close True
End With
  Next sh
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic    '啟用自動重算
End Sub

作者: edmondsforum 時間: 2020-6-30 13:51

回復 20# n7822123

真的太感謝龍大了!!!!!

真的不好意思，目前能力卻只能東湊湊西湊湊，還在努力理解各個程式碼的意思...努力學習中!!

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