返回列表 上一主題 發帖

[發問] 下個月新檔

本帖最後由 PJChen 於 2020-1-26 22:00 編輯

回復 9# 准提部林

請問准大,
同個檔案,Sheet以1~31命名,其中也有非數字的工作表,我需要一個可以刪除大於月底日工作表的功能(非數字的工作表不刪,目前排序,第一個工作表為文字工作表),如果當月正好是31天,也都不用刪除工作表,
程式碼很長,我只截取一部份,以下這句, 一直執行得很怪,存檔時為2月份日期,2月份有29日,它卻只刪除29、31的工作表,我需要刪除的是30、31的工作表,請問可以怎麼修正程式?
Sheets(j).Delete    '刪除大於月底日的工作表
  1.     Dim Path As String, myPath As String, File As String, xFile As String, i As String, m As String, xd As Long, j As Long, xJ As Long, k As Long
  2.     i = DateSerial(Year(Date), Month(Date) + 1, 1)  '設定下個月1日
  3.     m = Format(i, "M月") '設定下個月份
  4.     xd = Format(DateSerial(Year(Date), Month(Date) + 2, 1) - 1, "D")   '下個月底日變數

  5. With Workbooks.Open(Path & File)
  6.                 For j = 2 To ActiveWorkbook.Sheets.Count  '從#2開始的工作表中循環
  7.                     ActiveWorkbook.Sheets(j).Activate
  8.                         [A2] = [A2].Value '值化
  9.                         [B1] = [B1].Value '值化
  10.                         
  11.                         If j > xd Then
  12.                             Sheets(j).Delete    '刪除大於月底日的工作表
  13.                         End If
  14.                     Next
  15.                         Sheets("1").Activate
  16.                     For k = 1 To [U1]  '將U1儲存格的值,作為變數存取次數,依序命名檔案名並存檔
  17.                         [P1] = k   '指定儲存格的值
  18.                         ActiveWorkbook.SaveAs filename:=myPath & [G1] & " _" & m & ".xlsx"  'one by one 存檔k次
  19.                     Next
  20.                         ActiveWorkbook.Close True   '存檔後關閉檔案
  21.             End With
複製代碼

TOP

本帖最後由 准提部林 於 2020-2-10 16:16 編輯

Sub TEST()
Dim xPath$, xFile$, i&, k&
Dim Lastday$, mDay%, xBK As Workbook
Lastday = DateSerial(Year(Date), Month(Date) + 2, 0) '下個月月底
mDay = Day(Lastday) '下個月天數
Set xBK = Workbooks.Open(xPath & xFile) '開啟指定檔案
'-----------------------------------
Application.DisplayAlerts = False
On Error Resume Next
For i = mDay + 1 To 31: xBK.Sheets(i & "").Delete: Next i '刪工作表
On Error GoTo 0
Application.DisplayAlerts = True
'-----------------------------------
For i = 1 To mDay
    With xBK.Sheets(i & "")
         .[A2] = .[A2].Value '值化
              .[B1] = .[B1].Value '值化
    End With
Next i
End Sub

其它需求自行加入~~

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

TOP

回復 12# 准提部林

准大,
2月已經無法測試,3月又是31天,所以我測試4月
這句
For i = mDay + 1 To 31: BK.Sheets(i & "").Delete: Next i '刪工作表
與前面的Dim Lastday$, mDay%, xBK As Workbook不同,無法刪除大於月底日的工作表,所以我改為
For i = mDay + 1 To 31: xBK.Sheets(i & "").Delete: Next i
刪除大於月底日的工作表可執行,但又有其他地方卡關,請幫忙看下是否我有弄錯的語法??
  1. Sub EX()
  2. Dim Path$, File$, i&, k&
  3. Dim Lastday$, mDay%, xBK As Workbook, BK As Workbook
  4. Dim myPath$, xFile$, m$, h$
  5. Lastday = DateSerial(Year(Date), Month(Date) + 3, 0) '下下個月月底
  6. mDay = Day(Lastday) '下個月天數
  7. h = DateSerial(Year(Date), Month(Date) + 2, 1)  '設定下個月1日
  8. m = Format(h, "M月") '設定下個月份
  9. Application.ScreenUpdating = False  '關閉屏幕更新
  10. Application.DisplayAlerts = False   '一般提警示訊息關閉
  11.     Path = "U:\a\1.下個月理貨單\"  '來源資料夾
  12.     myPath = "U:\b\"                 '另存目的資料夾

  13.         File = Dir(Path & "*.xlsx")          '來源檔名
  14.             Do While File <> ""
  15.                 With Workbooks.Open(Path & File)
  16.                         On Error Resume Next
  17.                         Sheets("1").Activate
  18.                         [A2] = Format(h, "M/D")   '輸入指定日期,為下個月1日
  19.                         ActiveWorkbook.Save '**存檔不關閉
  20.                 End With

  21. Set xBK = Workbooks.Open(Path & File) '開啟指定檔案

  22.             On Error Resume Next
  23.             For i = mDay + 1 To 31: xBK.Sheets(i & "").Delete: Next i '刪工作表
  24.             On Error GoTo 0

  25.             For i = 1 To mDay
  26.                 With xBK.Sheets(i & "")
  27.                     .[A2] = .[A2].Value '值化
  28.                     .[B1] = .[B1].Value '值化
  29.                 End With
  30.             Next i
  31.                 For i = 1 To mDay  '在工作表中循環
  32.                     With xBK.Sheets(i & "")
  33.                         Sheets("1").Activate
  34.                         For k = 1 To [U1]  '將U1儲存格的值,作為變數存取次數,依序命名檔案名並存檔
  35.                             [P1] = k   '指定儲存格的值
  36.                             ActiveWorkbook.SaveAs filename:=myPath & [V2] & [G1] & " _" & m & ".xlsx" 'one by one 存檔k次
  37.                         Next
  38.                             ActiveWorkbook.Close True   '存檔後關閉檔案
  39.                     End With
  40.                 Next i
  41.     File = Dir
  42.         Loop
複製代碼

TOP

回復 13# PJChen

紅色字體為修改語法:
Sheet刪除由左向右會造成異常
For i = mDay + 1 To 31: xBK.Sheets(i & "").Delete: Next i '刪工作表
改為由右向左刪除
For i = 31 To mDay + 1 Step -1: xBK.Sheets(i & "").Delete: Next i

藍色字體為刪除
試試看!!

Sub EX()
Dim Path$, File$, i&, k&
Dim Lastday$, mDay%, xBK As Workbook, BK As Workbook
Dim myPath$, xFile$, m$, h$
Lastday = DateSerial(Year(Date), Month(Date) + 3, 0) '下下個月月底
mDay = Day(Lastday) '下個月天數
h = DateSerial(Year(Date), Month(Date) + 2, 1)  '設定下個月1日
m = Format(h, "M月") '設定下個月份
Application.ScreenUpdating = False  '關閉屏幕更新
Application.DisplayAlerts = False   '一般提警示訊息關閉
    Path = "D:\backup20060523\MDBView\麻辣學園\1.下個月理貨單_測試\檔案\"  '來源資料夾
    myPath = "D:\backup20060523\MDBView\麻辣學園\1.下個月理貨單_測試\2_暫\"                '另存目的資料夾

        File = Dir(Path & "*.xlsx")          '來源檔名
            Do While File <> ""
                With Workbooks.Open(Path & File)
                        On Error Resume Next
                        Sheets("1").Activate
                        [A2] = Format(h, "M/D")   '輸入指定日期,為下個月1日
                        ActiveWorkbook.Save '**存檔不關閉
                End With

Set xBK = Workbooks.Open(Path & File) '開啟指定檔案

            On Error Resume Next
         '   For i = mDay + 1 To 31: xBK.Sheets(i & "").Delete: Next i '刪工作表
            For i = 31 To mDay + 1 Step -1: xBK.Sheets(i & "").Delete: Next i '刪工作表
            On Error GoTo 0

            For i = 1 To mDay
                With xBK.Sheets(i & "")
                    .[A2] = .[A2].Value '值化
                    .[B1] = .[B1].Value '值化
                End With
            Next i
             '   For i = 1 To mDay  '在工作表中循環
             '       With xBK.Sheets(i & "")
                        Sheets("1").Activate
                        For k = 1 To [U1]  '將U1儲存格的值,作為變數存取次數,依序命名檔案名並存檔
                            [P1] = k   '指定儲存格的值
                            ActiveWorkbook.SaveAs Filename:=myPath & [V2] & [G1] & " _" & m & ".xlsx" 'one by one 存檔k次
                        Next
                            ActiveWorkbook.Close True   '存檔後關閉檔案
             '       End With
             '   Next i
    File = Dir
        Loop

TOP

回復 14# jcchiang

i=31
sheets(i).delete = 刪除第31張工作表
sheets(i & "").delete = 刪除名稱"31"的工作表, 所以刪除方向不限

TOP

回復 14# jcchiang

改這樣可以正常運作了
謝謝

TOP

回復 15# 准提部林

請問准大,
For i = mDay + 1 To 31: xBK.Sheets(i & "").Delete: Next i '刪工作表
可以刪除大於月底日的工作表
但卡在這裡無法執行,是什麼問題?
                For i = 1 To mDay  '在工作表中循環
                    With xBK.Sheets(i & "")
                        Sheets("1").Activate
                        For k = 1 To [U1]

TOP

回復 15# 准提部林

了解,謝謝准大的指導

TOP

回復 17# PJChen

是因為妳要做For i = 1 To mDay的檔案已經關閉了

TOP

本帖最後由 PJChen 於 2020-2-10 18:18 編輯

回復 15# 准提部林
回復 19# jcchiang

前一個程式結束後,我還要作後續的檔案處理,我延用之前的語法,一樣是測試4月份,
以工作表中的Sheets("1").Range("A2")的日期(2020/4/1),抓月底日
改為這樣,但為什麼紅色部份,仍無法執行?
Lastday = DateSerial(Year(BK.Sheets("1").Range("A2")), Month(BK.Sheets("1").Range("A2")), 0) '月底日
mDay = Day(Lastday)
For i = 1 To mDay
With BK.Sheets(i & "")
  1. Sub 下個月_理貨單_目的檔表頭值化()
  2. '比菲多理貨單
  3. Dim Lastday$, mDay%, BK As Workbook
  4. Dim myPath$, xFile$, i&

  5. Application.ScreenUpdating = False  '關閉屏幕更新
  6. Application.DisplayAlerts = False   '一般提警示訊息關閉
  7.     myPath = "U:\b\"                 '另存目的資料夾

  8.     xFile = Dir(myPath & "*.xlsx")          '目的資料夾檔名
  9.         Do While xFile <> ""
  10.             Application.DisplayAlerts = False       '一般提警示訊息關閉
  11.                 With Workbooks.Open(myPath & xFile)
  12.                     Set BK = Workbooks.Open(myPath & xFile) '開啟指定檔案
  13.                     Lastday = DateSerial(Year(BK.Sheets("1").Range("A2")), Month(BK.Sheets("1").Range("A2")), 0) '月底日
  14.                     mDay = Day(Lastday)
  15.                     For i = 1 To mDay   '在工作表中循環
  16.                         With BK.Sheets(i & "")
  17.                         .[G1] = .[G1].Value '值化
  18.                         .[A1] = .[A1].Value '值化
  19.                         End With
  20.                     Next i
  21.                         Sheets("1").Activate
  22.                         Range("P1:V2").ClearContents
  23.                         Sheets("1").Range("G1") = Sheets("2").Range("G1").Value
  24.                         ActiveWorkbook.Close True   '存檔後關閉檔案
  25.                 End With
  26.     xFile = Dir
  27.         Loop
  28.                 Application.ScreenUpdating = True   '打開屏幕更新

  29. End Sub
複製代碼

TOP

        靜思自在 : 自己害自己,莫過於亂發脾氣。
返回列表 上一主題