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

edmondsforum

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

1. Sub test3()
   
2. 
   
3.     Dim I As Long
   
4.     Dim xWeek As Integer
   
5.     Dim xS As Worksheet
   
6.     Dim xPH$
   
7.     xPH = ThisWorkbook.Path & "\"
   
8.    
   
9.     On Error Resume Next
   
10.    
    
11.     Application.ScreenUpdating = False
    
12.    
    
13.     Set xS = Sheets("週報表")
    
14.         xWeek = InputBox("請輸入第""?""週")
    
15.             xS.Copy After:=Sheets(Sheets.Count)            
    
16.             ActiveSheet.Name = "第" & xWeek & "週"
    
17.                 Set xName = ActiveSheet
    
18.                     xName.Copy
    
19.                     
    
20.             Application.DisplayAlerts = False
    
21.             
    
22.                 With xName.UsedRange
    
23.                     .Value = .Value
    
24.                 End With                                                         
    
25. 
    
26.                 With ActiveWorkbook
    
27.                     ActiveSheet.Name = "第" & xWeek & "週"
    
28.                     .SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
    
29.                     .Close
    
30.                 End With
    
31.                
    
32.     Application.ScreenUpdating = True
    
33.    
    
34. End Sub

複製代碼

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

1.          
   
2.                     With xName.UsedRange
   
3.                     .Value = .Value
   
4.                     End With   

複製代碼

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

1.                
   
2.                    With ActiveWorkbook
   
3.                     ActiveSheet.Name = "第" & xWeek & "週"
   
4.                     .SaveAs xPH & "第" & xWeek & "週.xlsx", CreateBackup:=False
   
5.                     .Close
   
6.                   End With
   

複製代碼

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

edmondsforum

回復 20# n7822123

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

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

n7822123

回復 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

回復 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 會跑不出第三週呢 真奇怪....

再麻煩龍大看一下附件

TEST0630_2.zip (335.56 KB)

下載次數: 7

2020-6-30 11:16

n7822123

回復 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)

下載次數: 3

2020-6-30 03:29

n7822123

回復 16# edmondsforum


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

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

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

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

就沒問題了，程式如下


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

edmondsforum

回復 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)

下載次數: 4

2020-6-30 01: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


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

n7822123

回復 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

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

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

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

出門了，掰掰

n7822123

回復 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)

下載次數: 6

2020-6-25 01:27