VBA修改 : 複製有函數的工作表，並另存到新的工作簿 - Excel程式區

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

2^#

發表於 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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

3^#

發表於 2020-6-24 11:58 | 顯示全部帖子

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

回復 5# edmondsforum

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

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

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

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

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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

4^#

發表於 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晚上才能回覆

Test-0625.rar (424.62 KB)

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

5^#

發表於 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

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

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

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

出門了，掰掰

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

6^#

發表於 2020-6-30 02:50 | 顯示全部帖子

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

回復 16# edmondsforum

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

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

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

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

就沒問題了，程式如下

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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

7^#

發表於 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]

Test-0630.rar (253.47 KB)

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

8^#

發表於 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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助