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

標題: [發問] 下個月新檔 [打印本頁]

作者: PJChen 時間: 2019-11-26 00:04 標題: 下個月新檔

Dear,
我有一個程式,是為了可以自動run下個月的新檔案而設
最近新增一段程式,結果變成一直循環貼資料
若把有問題的這一段註解,則程式就沒有問題
請大大們幫忙看下程式...感謝

VB作業內容:
在資料夾中打開檔案群
輸入下個月1日的日期,存檔不關閉
值化日期儲存格
刪除大於月底日的工作表
另存目的資料夾
依P1的工作表名稱數量,依序命名檔案名並分別存檔
目的工作表打開,值化每個工作表頭的名稱並clear原公式
依P1的工作表名稱數量,依序命名檔案名並分別存檔
目的工作表打開,值化每個工作表頭的名稱並clear原公式

*******************我希望達到的新增加功能(有問題,會一直循環貼資料)
1. 自動偵測商品.xlsx是否已開啟,已開則忽略,未開則打開
2. 自動偵測商品.xlsx的列數(商品.xlsx會有最新的產品資料,而且列數會有增加及減少的可能性)
3. 把資料的"值"(不要格式)貼到理貨單的第一個工作表"出貨數" (有２個測試檔：飛比_暖暖.湖口.xlsx／BF-QOO.xlsx,正式的作業還會有更多的檔案）

因為我不會寫這段程式,所以是用手動的做法：
進程式中修改,指定A19選取一整列,預設為複製一列,如要刪除一列,則要
這表示要先知道出貨數與商品欄的列數有多少不同
然後程式會將Workbooks("商品.xlsx").Sheets("飛比商品").Range("商品欄")的資料自動貼上
目前預設是插入一列後,貼上商品資料
若是資料不需變動時,要註解掉,就不會執行

用寫的可能無法很詳細,我已把有問題這一段註解了,先run下程式, 可能就明白我在說什麼！
[attach]31454[/attach]

作者: luhpro 時間: 2019-11-29 21:20

本帖最後由 luhpro 於 2019-11-29 21:26 編輯

Dear,
...
1. 自動偵測商品.xlsx是否已開啟,已開則忽略,未開則打開...
PJChen 發表於 2019-11-26 00:04

先解決你的第一個問題,
在你發的那串 : [發問] 自動套表 5# 第 5 篇裡,
我的回文裡有一段就是在處理你這個需求 :

sPath = ThisWorkbook.Path ' 如果要指定目錄, 只要改成該目錄即可, 如 sPath = "D:"
sFlName = "商品.xlsx"
bMatch = False ' 檢查 '商品.xlsx' 檔案是否已開啟
For iI = 1 To Workbooks.Count
If Workbooks(iI).Name = sFlName Then
bMatch = True
Exit For
End If
Next iI
If bMatch Then
Set wsTar = Workbooks(sFlName).Sheets("飛比商品") ' 檔案已開啟, 直接取用
wsTar.Activate
Else
Set wsTar = Workbooks.Open(Filename:=sPath & "\" & sFlName).Sheets("飛比商品") ' 檔案尚未開啟, 開啟後取用
End If
With wsTar
....
End With

複製代碼

取用時只要在 With wsTar 與 End With 兩行間用 . 開頭的指令即可,
例如 : .[A5] = 16 或 .Cells(3,5)=2 ...等

2. 自動偵測商品.xlsx的列數(商品.xlsx會有最新的產品資料,而且列數會有增加及減少的可能性)

最末列號可以用類似

lRow = .Cells(Rows.Count, 1).End(XlUp).Row ' 1 表取得 A 欄最末有資料列號

複製代碼

取得
有事先下了,
其它的若我有時間上來再互相討論.

作者: PJChen 時間: 2019-12-16 15:11

回復 2# luhpro
lRow = .Cells(Rows.Count, 1).End(XlUp).Row ' 1 表取得 A 欄最末有資料列號
這個檔我研究了很多天了,還是寫不出後面的程式，不知道如何套用到

2. 自動偵測商品.xlsx的列數(商品.xlsx會有最新的產品資料,而且列數會有增加及減少的可能性)
因為它偵測到 "飛比_暖暖.湖口.xlsx/ BF-QOO.xlsx"的列數後還要與來源檔商品.xlsx比對,列數是多還是少?
依"商品.xlsx"的列數為準,
多的列數.....把多出來的刪除
少的列數.....把不足的列數新增
最後把"商品.xlsx" 的這三欄 "料號入數商品名稱"的值(不要格式)
copy到目的資料夾的檔案(目前是 "飛比_暖暖.湖口.xlsx/ BF-QOO.xlsx")

作者: PJChen 時間: 2019-12-29 18:03

本帖最後由 PJChen 於 2019-12-29 18:04 編輯

Dear,
之前想要的做法完全做不出來,我想將程式這個功能單獨拉出來,使之簡化
以Workbooks("商品.xlsx").Sheets("新月") A4:C底為資料來源
1) copy值到 "1.下個月理貨單_測試"資料夾中的每個檔案Sheets("出貨數")的A3:C
2) 再以Sheets("新月") A4:C底判斷列數
3) 當Sheets("出貨數")的A3:C的列數=Sheets("新月") A4:C 則存檔關閉
4) 當Sheets("出貨數")的A3:C的列數>Sheets("新月") A4:C 則刪除多的列數存檔關閉
5) 當Sheets("出貨數")的A3:C的列數<Sheets("新月") A4:C 則把D欄公式往下複制,如同Sheets("新月") A4:C底的列數存檔關閉

現在做第一個copy資料的功能,一直無法正常貼資料,可否幫忙看下?? [attach]31601[/attach]

作者: 蒼雪 時間: 2020-1-5 23:21

本帖最後由蒼雪於 2020-1-5 23:22 編輯

回復 4# PJChen

小弟我試著改了一下，請服用。

原本你寫的我有保留，變成註解情況，可以跟我寫的區塊比對一下。

因為要抓商品的row數量，所以 cells(rows.count,"C").end(xlup).row 必須是以...

workbooks("商品.xlsx").WORKSHEETS("新月").cells(rows.count,"C").end(xlup).row下去寫，才會去抓到該Sheet的row數量。

前提是workbook 商品是要開啟的狀態。[attach]31626[/attach]

作者: PJChen 時間: 2020-1-8 21:53

回復 5# 蒼雪

先謝謝你的程式,
測試結果:程式會一直循環,停不下來,最後要按ESC去終止它,可以怎麼修正呢?......另
4)~5) 的判斷語法,哪位大大教學一下嗎?
1) copy值到 "1.下個月理貨單_測試"資料夾中的每個檔案Sheets("出貨數")的A3:C
2) 再以Sheets("新月") A4:C底判斷列數
3) 當Sheets("出貨數")的A3:C的列數=Sheets("新月") A4:C 則存檔關閉

4) 當Sheets("出貨數")的A3:C的列數>Sheets("新月") A4:C 則刪除多的列數存檔關閉
5) 當Sheets("出貨數")的A3:C的列數<Sheets("新月") A4:C 則把D欄公式往下複制,如同Sheets("新月") A4:C底的列數存檔關閉

作者: PJChen 時間: 2020-1-8 22:41

回復 5# 蒼雪

後來改成這樣就不會一直循環了,現在我只剩4~5還沒成功....

Path = ".......\1.日班理貨換算表\" '另存目的資料夾
File = Dir(Path & "*.xlsx") '來源檔名
Do While File <> ""
Set mySheet = Workbooks("商品.xlsx").Worksheets("新月")
iRow = mySheet.Cells(Cells.Rows.Count, "C").End(xlUp).Row '看C欄位幾筆資料
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 來源資料夾理貨單 Sheets("出貨數")新增.刪除
With Workbooks.Open(Path & File)
ActiveWorkbook.Sheets("出貨數").Activate
Range("A3:C" & iRow - 1).Value = mySheet.Range("A4:C" & iRow).Value 'iRow計算來源檔的列數,從A4開始,目的檔從A3開始,會多貼一列,所以目的檔要-1
ActiveWorkbook.Close True '存檔後關閉檔案
End With
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
File = Dir
Loop
End Sub

複製代碼

作者: 蒼雪 時間: 2020-1-10 19:19

回復 6# PJChen

會循環嗎...我自己在run的時候是沒問題啦XD

作者: 准提部林 時間: 2020-1-14 11:15

測試檔:
[attach]31638[/attach]

作者: PJChen 時間: 2020-1-14 15:58

回復 9# 准提部林

謝謝准大,
稍修改路徑,執行OK

作者: PJChen 時間: 2020-1-26 21:47

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

回復 9# 准提部林

請問准大,
同個檔案,Sheet以1~31命名,其中也有非數字的工作表,我需要一個可以刪除大於月底日工作表的功能(非數字的工作表不刪,目前排序,第一個工作表為文字工作表),如果當月正好是31天,也都不用刪除工作表,
程式碼很長,我只截取一部份,以下這句, 一直執行得很怪,存檔時為2月份日期,2月份有29日,它卻只刪除29、31的工作表,我需要刪除的是30、31的工作表,請問可以怎麼修正程式?
Sheets(j).Delete '刪除大於月底日的工作表

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
i = DateSerial(Year(Date), Month(Date) + 1, 1) '設定下個月1日
m = Format(i, "M月") '設定下個月份
xd = Format(DateSerial(Year(Date), Month(Date) + 2, 1) - 1, "D") '下個月底日變數
With Workbooks.Open(Path & File)
For j = 2 To ActiveWorkbook.Sheets.Count '從#2開始的工作表中循環
ActiveWorkbook.Sheets(j).Activate
[A2] = [A2].Value '值化
[B1] = [B1].Value '值化
If j > xd Then
Sheets(j).Delete '刪除大於月底日的工作表
End If
Next
Sheets("1").Activate
For k = 1 To [U1] '將U1儲存格的值,作為變數存取次數,依序命名檔案名並存檔
[P1] = k '指定儲存格的值
ActiveWorkbook.SaveAs filename:=myPath & [G1] & " _" & m & ".xlsx" 'one by one 存檔k次
Next
ActiveWorkbook.Close True '存檔後關閉檔案
End With

複製代碼

作者: 准提部林 時間: 2020-2-9 10:53

本帖最後由准提部林於 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

其它需求自行加入~~

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

作者: PJChen 時間: 2020-2-9 23:23

回復 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
刪除大於月底日的工作表可執行,但又有其他地方卡關,請幫忙看下是否我有弄錯的語法??

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 = "U:\a\1.下個月理貨單\" '來源資料夾
myPath = "U:\b\" '另存目的資料夾
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 '刪工作表
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

複製代碼

[attach]31690[/attach]

作者: jcchiang 時間: 2020-2-10 11:49

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

作者: 准提部林 時間: 2020-2-10 16:15

回復 14# jcchiang

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

作者: PJChen 時間: 2020-2-10 16:17

回復 14# jcchiang

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

作者: PJChen 時間: 2020-2-10 16:21

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

作者: jcchiang 時間: 2020-2-10 16:45

回復 15# 准提部林

了解,謝謝准大的指導

作者: jcchiang 時間: 2020-2-10 16:52

回復 17# PJChen

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

作者: PJChen 時間: 2020-2-10 18:17

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

Sub 下個月_理貨單_目的檔表頭值化()
'比菲多理貨單
Dim Lastday$, mDay%, BK As Workbook
Dim myPath$, xFile$, i&
Application.ScreenUpdating = False '關閉屏幕更新
Application.DisplayAlerts = False '一般提警示訊息關閉
myPath = "U:\b\" '另存目的資料夾
xFile = Dir(myPath & "*.xlsx") '目的資料夾檔名
Do While xFile <> ""
Application.DisplayAlerts = False '一般提警示訊息關閉
With Workbooks.Open(myPath & xFile)
Set BK = Workbooks.Open(myPath & xFile) '開啟指定檔案
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 & "")
.[G1] = .[G1].Value '值化
.[A1] = .[A1].Value '值化
End With
Next i
Sheets("1").Activate
Range("P1:V2").ClearContents
Sheets("1").Range("G1") = Sheets("2").Range("G1").Value
ActiveWorkbook.Close True '存檔後關閉檔案
End With
xFile = Dir
Loop
Application.ScreenUpdating = True '打開屏幕更新
End Sub

複製代碼

作者: jcchiang 時間: 2020-2-11 12:57

回復 20# PJChen
Sheets("1").Range("A2")的日期(2020/4/1),抓月底日
Lastday = DateSerial(Year(BK.Sheets("1").Range("A2")), Month(BK.Sheets("1").Range("A2")), 0) '月底日
這樣Lastday是2020/3/31
mDay = Day(Lastday)是31
改成Lastday = DateSerial(Year(BK.Sheets("1").Range("A2")), Month(BK.Sheets("1").Range("A2")) +1, 0) '月底日
Lastday是2020/4/30
mDay = Day(Lastday)是30

作者: PJChen 時間: 2020-2-11 16:10

回復 21# jcchiang

好的,測試成功了
感謝

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