PJChen

回復 7# Hsieh

大大,

我想將你寫的這個程式套到以下這幾個模式中，目前只先嘗試"訂單明細表",但一直不成功！可否請你示範下如何修改程式內容？    出貨文件連結.rar (97.66 KB)

下載次數: 3

2017-7-16 14:49

來源檔 Q:\00_科毅\出貨文件連結\FromERP\
訂單明細表.xlsx
請購單明細表.xlsx
採購單明細表.xlsx
進貨單明細表.xlsx
領料單明細表.xlsx
出貨單明細表.xlsx

目的檔 Q:\00_科毅\出貨文件連結\ERP_Data.xlsx
訂單.sheet
請購.sheet
採購.sheet
進貨.sheet
領料.sheet
出貨.sheet

準則存放的檔案及儲存格
Q:\00_科毅\出貨文件連結\VBA報表指令.xlsm
訂單明細表            H2
請購單明細表        H3
採購單明細表        H4
進貨單明細表        H5
領料單明細表        H6
出貨單明細表        H7

訂單明細表的套表模式為：
1. 以VBA報表指令.xlsm H2為準則,搜尋訂單明細表的B2欄位,當符合H2時(目前的值是MSO17060001)
2. 目前符合的儲存格是B11,則copy B11~BA的資料最底端,如果找不到代表沒有資料可複製.
3. 貼上資料至目的檔 Q:\00_科毅\出貨文件連結\ERP_Data.xlsx的"訂單.sheet",符合B欄MSO17060001的位置,並直接覆蓋原資料,選擇性貼上值(不要更改原資料的格式),如果找不到時,就當成是最新的資料,直接從目的檔的B欄最底端下一欄的空白列貼上(所以要能自動偵測資料的最末端,如果有全列空白(非全列空白不算是空白),其空白的第一列(若有空白列後再出現的資料視同空白)即是貼新資料的地方.

注意事項:
1. 來源檔及目的檔的資料都來自系統Download的報表,所以資料多寡是會變動的
2. 準則存放的H2~H7,其值也會隨著需求而變動
3. 目的檔每個sheet都有設定組成群組,是否應有先打開群組的動作,資料才會貼正確位置？
4. 當資料貼完以後,要再隱藏群組

GBKEE

回復 11# PJChen
重新回到 11# 的問題
問題複雜可以一個一個來
**********************************
訂單明細表的套表模式為：
1. 以VBA報表指令.xlsm H2為準則,搜尋訂單明細表的B2欄位,當符合H2時(目前的值是MSO17060001)
2. 目前符合的儲存格是B11,則copy B11~BA的資料最底端,如果找不到代表沒有資料可複製.
3. 貼上資料至目的檔 Q:\00_科毅\出貨文件連結\ERP_Data.xlsx的"訂單.sheet",符合B欄MSO17060001的位置,並直接覆蓋原資料,選擇性貼上值(不要更改原資料的格式),如果找不到時,就當成是最新的資料,直接從目的檔的B欄最底端下一欄的空白列貼上(所以要能自動偵測資料的最末端,如果有全列空白(非全列空白不算是空白),其空白的第一列(若有空白列後再出現的資料視同空白)即是貼新資料的地方.
********************************

1. Option Explicit
   
2. Dim 目的檔 As Workbook, 來源檔 As Workbook
   
3. Dim 準則單號 As String, 準則單號_Rng As Range
   
4. Dim 欄位 As String, 工作頁 As String, Msg As String
   
5. Sub Main()
   
6.     Dim Table As Range, Sh As Worksheet, i As Integer
   
7.     Msg = ""
   
8.     With ThisWorkbook.Sheets("VBA指令")           '設定準則範圍
   
9.         Set Table = .Range("G2", .Range("G2").End(xlDown)).Resize(, 2)   '
   
10.     End With
    
11.     File_settings 目的檔, "ERP_Data.XLSX"    '設定目的檔
    
12.     For i = 1 To Table.Rows.Count
    
13.         File_settings 來源檔, Table.Cells(i, 1) & ".XLSX"  '設定來源檔
    
14.         準則單號 = Table.Cells(i, 2)          '讀取準則
    
15.         工作頁 = Mid(Table.Cells(i, 1), 1, 2)    '目的檔的工作表名稱
    
16.         欄位 = IIf(工作頁 = "訂單" Or 工作頁 = "進貨" Or 工作頁 = "領料", "C:C", "B:B") '目的檔的工作表的欄位
    
17.         xSearch
    
18.         來源檔.Close False
    
19.     Next
    
20.     '******************************
    
21.     '目的檔.Close True   暫時不存檔
    
22.     '******************************
    
23.     If Msg <> "" Then MsgBox Msg
    
24. End Sub
    
25. Private Sub xSearch()
    
26.     Dim D As Object, M, 工作頁 As String
    
27.     Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
    
28.     With 來源檔.Sheets(1) '.Range("b:b")          '來源檔第一個工作表的B欄
    
29.         .Cells.Sort .Range("B1"), 1, Header:=xlYes   '排序
    
30.         M = Application.Match(準則單號, .Range("b:b").Cells, 0)
    
31.         '**********************************
    
32.         If IsError(M) Then Exit Sub  '來源檔沒有找到準則,離開這程式 (不處理)
    
33.         '**找到準則,設定準則的資料範圍
    
34.         With .Range("b:b")
    
35.             Do While .Cells(M) = 準則單號
    
36.                 '.Range("B" & M & ":BA" & M) -> 共27欄
    
37.                 If TypeName(D(.Cells(M).Value)) <> "Range" Then
    
38.                     Set D(準則單號) = .Range("a" & M).Resize(, 27)
    
39.                 Else
    
40.                     Set D(準則單號) = Union(D(準則單號), .Range("a" & M).Resize(, 27))
    
41.                 End If
    
42.                 M = M + 1
    
43.             Loop
    
44.         End With
    
45.         Set 準則單號_Rng = D(準則單號)
    
46.     End With
    
47.     目的檔_準則單號
    
48. End Sub
    
49. Private Sub 目的檔_準則單號()
    
50.     Dim M As Variant, D As Object, xRng As Range, i As Integer, 工作頁單號_Rng As Range
    
51.    
    
52.     With 目的檔.Sheets(工作頁)
    
53.         '目的檔的工作頁有無準則單號
    
54.         M = Application.Match(準則單號, .Range(欄位), 0)
    
55.         '**************************
    
56.         If IsError(M) Then   '無準則單號
    
57.             M = Split(.UsedRange.Address, "$")
    
58.             M = M(UBound(M))       '工作頁最底端的列
    
59.             Do While Application.CountA(.Rows(M)) > 1  '必需沒有資料
    
60.                 M = M + 1
    
61.             Loop
    
62.             '*********************************
    
63.             Set 工作頁單號_Rng = .Range(欄位).Cells(M).Resize(準則單號_Rng.Rows.Count, 準則單號_Rng.Columns.Count)
    
64.             Msg = Msg & vbLf & 工作頁 & " 加入: " & 準則單號
    
65.         Else       ''有準則單號
    
66.             Set D = CreateObject("SCRIPTING.DICTIONARY")
    
67.             .Cells.Sort .Range(欄位).Cells(1), 1, Header:=xlYes            '先排序
    
68.             With .Range(欄位)
    
69.                 M = Application.Match(準則單號, .Cells, 0)  '尋找單號列號
    
70.                 '設定 工作頁準則單號的範圍*********
    
71.                 Do While .Cells(M) = 準則單號
    
72.                     If TypeName(D(.Cells(M).Value)) <> "Range" Then
    
73.                         Set D(準則單號) = .Range("a" & M).Resize(, 27)
    
74.                     Else
    
75.                         Set D(準則單號) = Union(D(準則單號), .Range("a" & M).Resize(, 27))
    
76.                     End If
    
77.                     M = M + 1
    
78.                 Loop
    
79.             End With
    
80.             With D(準則單號)
    
81.                 If .Rows.Count > 準則單號_Rng.Rows.Count Then  '工作頁單號列數>準則單號列數
    
82.                     For i = .Rows.Count To 準則單號_Rng.Rows.Count + 1 Step -1
    
83.                         Rows(i).EntireRow.Delete                    '整列刪除
    
84.                     Next
    
85.                 ElseIf .Rows.Count < 準則單號_Rng.Rows.Count Then   '工作頁單號列數<準則單號列數
    
86.                     For i = .Rows.Count + 1 To 準則單號_Rng.Rows.Count
    
87.                         Rows(i + 1).EntireRow.Insert                '新增一列
    
88.                     Next
    
89.                 End If
    
90.             End With
    
91.             Set 工作頁單號_Rng = D(準則單號).Resize(D(準則單號).Rows.Count)
    
92.             Msg = Msg & vbLf & 工作頁 & " 更新: " & 準則單號 & " 完畢"
    
93.         End If
    
94.     End With
    
95.     With 工作頁單號_Rng
    
96.         .Value = 準則單號_Rng.Value
    
97.         .BorderAround ColorIndex:=3, Weight:=xlThick
    
98.     End With
    
99. End Sub
    
100. Sub File_settings(xFile As Workbook, 工作頁 As String) '檔案設定
     
101.     Dim xPath As String
     
102.     xPath = ThisWorkbook.Path & "\"
     
103.     If UCase(工作頁) <> UCase("ERP_Data.XLSX") Then xPath = xPath & "FromERP\"
     
104.     On Error Resume Next
     
105.     Set xFile = Workbooks(工作頁)
     
106.     If Err > 0 Then Set xFile = Workbooks.Open(xPath & 工作頁)
     
107.     If xFile.Name = "" Then
     
108.         MsgBox "請查看 " & vbLf & xPath & vbLf & "是否有 [" & 工作頁 & "]"
     
109.         End
     
110.     End If
     
111. End Sub

複製代碼

PJChen

回復 12# GBKEE

下載 (188.17 KB)

2017-7-25 23:05

大大,
我挑了其中一個檔來說明...
我看著它執行幾次，初時有點看不懂，因為來源檔及目的檔的資料都對不上，而且它執行過程中一直在存檔。後來我直接把來源檔及目的檔的單據號碼貼在一起比對，發現如下：
1) 目的檔的資料被排序過，而且只有單號排序，其他的欄沒有跟著變動，所以資料錯亂(其實我不要資料排序，我只要按原資料貼上而且是貼上值就好)
2) 目的檔的資料跟之前一樣,當來源檔資料比較少時,它無法Delete多餘的資料 (我一直在思考這個問題,如果這個部份的程式很難達成，乾脆所有的檔案在更新資料後，所有貼上的資料都維持反黑的狀態，意思就像下面的圖檔，更新的資料是B:BF15747,讓反黑保留下來,我一看就知道哪個區塊是更新過的，我再手動Delete 15748:15755，你覺得這樣如何？會不會比較好寫？

下載 (152.93 KB)

2017-7-25 23:19

3) 執行過程中一直在存檔，這個部份我想只要最後存檔就好了，不然檔案大反而花時間一直在等待，而且我想ERP_Data.xlsx 我一直都在使用，改為存檔後不關閉.
4) ...其實我也暈了，不知道怎麼回覆比較好，等改好以上這些我再try看看有什麼問題吧.
5) 還有Y...我之前二個有關聯的發問放在同一個主題中都被你刪除了，我又要重新發問了，我已經先將其中一個較簡單的先PO上去，另一個正好我在作業當中，發現需求有變動，等我想好了確定要怎麼執行再PO上吧，當然我會用另一個主題，不會混在一起讓你發昏了。

PJChen

回復 13# PJChen

大大,

我今天一測試就卡住了，我不知道有什麼地方要修改，所以先PO上來給你看...
雖然刪了很多資料,檔案還是超過1MB,所以我有分割再上傳.

Try_20170726.part1.rar (600 KB)

下載次數: 1

2017-7-26 19:41

Try_20170726.part2.rar (463.64 KB)

下載次數: 2

2017-7-26 19:41

GBKEE

回復 14# PJChen

12#的程式碼,今天已更新,請重試看看,準則複製到目的檔有用紅框框上.

PJChen

回復 15# GBKEE

大大,
我踹了新的程式好幾次,腦子有點錯亂了，我不知道所執行的結果是否真如我所說，我把來源檔的單號都貼在每個目的檔的最後一欄以方便來回比對，我把我所要的及看到的結果描述一下...
需求：
1. 這6個sheet真的沒有排序的需求,請不要讓它排序,不然資料會亂掉.
2. 更新之後,也不要在目的檔加紅色框線,因為它在功能上沒有的實質的需求,不過因為你這次加了框線,我發現準則不要變動，執行了2次以後就有2個框線,這是否說明它的執行結果有誤？

看到的結果：
3. 它好像更新資料到第N列就不能更新,後面有些新的資料完全沒有貼上.
4. 多餘的資料無法刪除,我不確定新的程式是否沒有這個功能？
5. 我在出貨.sheet實驗,刪除了很多資料,想看它的更新情形，發現沒有更新功能！

結論：
6. 所以其實我不知道它到底能否更新資料.

Try_20170727.part1.rar (600 KB)

下載次數: 7

2017-7-27 22:07

Try_20170727.part2.rar (466.57 KB)

下載次數: 3

2017-7-27 22:07

GBKEE

回復 16# PJChen

1.沒有排序的需求
  來源檔,目的檔中的單號,都不一定只有一列對嗎?
  那來源檔,目的檔中的單號都會連續排在一起嗎?
這有關程式碼的編寫
2不要在目的檔加紅色框線,因為它在功能上沒有的實質的需求
   加紅框是壤你看到更新的資料在那裡,

1. With 工作頁單號_Rng
   
2.         .Value = 準則單號_Rng.Value
   
3.        '這可以刪掉它
   
4.        '.BorderAround ColorIndex:=3, Weight:=xlThick
   
5.     End With

複製代碼

3. 它好像更新資料到第N列就不能更新,後面有些新的資料完全沒有貼上
.   你的範例      訂單明細表-> MSO17020036 在B2   ,B2以後的資料是新的資料嗎?
   全都貼到 ERP_Datq的訂單嗎!

4. 多餘的資料無法刪除,我不確定新的程式是否沒有這個功能？
  還沒,請問如何判斷多餘的資料

PJChen

回復 17# GBKEE

大大,

前面許多次的實驗，感覺是因為程式需求不夠明確，所以執行時一直都有錯誤，這次我把目的檔的貼上欄位改為一樣,我想這樣比較有一致性，而且我可能要用到這個欄位，可以避免日後的修改，可否把前面的種種抹掉，重新來過？

準則：       
1..        準則來自VBA報表指令.xlsm VBA指令.sheet G2:H7
2..       

下載 (40.88 KB)

2017-7-29 19:56

       
來源檔被複製規則：       
3..        準則指定的單號是來源檔要被複製內容的起始點(當同一單號有多筆時,以第一筆為起始準則),一直到最後一列為結束
4..        準則指定的單號若在來源檔找不到….就是沒有內容要被複製(直接跳過)
       
目的檔更新規則：       
5..        準則指定的單號也是目的檔要更新內容的起始點(當同一單號有多筆時,以第一筆為起始準則),一直到最後一列為結束
        當更新資料貼上後,最後一列若還有資料,則clear一整列(目的檔sheet所指定更新內容的區間,Column前後皆有資料,所以要clear一整列)

下載 (188.6 KB)

2017-7-29 19:54

6..        準則指定的單號若在目的檔找不到….表示更新的資料是全新的,就從目的檔的最後一列貼上更新資料

下載 (179.3 KB)

2017-7-29 19:54

VBA程式需求：       
7..        來源檔及目的檔的內容多寡並沒有一定，所以不能用指定儲存格的方式做複製.貼上
8..        目的檔原本的格式不要被覆蓋,所以更新時只要貼上值
9..        所有sheet的單號同一個月的內容並無順序,只有日期才有順序,所以來源檔及目的檔的內容都不要被排序
10..        來源檔及目的檔在程式執行時要可以自動判斷檔案是否有開啟,未開啟則使用時自動打開
11..        更新資料後,來源檔不要存檔直接關閉
12..        更新資料後,目的檔被更新的內容保留反黑的區塊 (這個只是為了方便檢視被更新的內容,而又不會有框線存在,如果這個部份的程式太難寫,可以忽略)

下載 (185.29 KB)

2017-7-29 19:54

13..        更新資料後,目的檔最後才存檔而且不要關閉
Try_20170729.part1.rar (550 KB)

下載次數: 7

2017-7-29 19:55

Try_20170729.part2.rar (502.08 KB)

下載次數: 6

2017-7-29 19:55

GBKEE

回復 18# PJChen
有夠清楚的,提問就是要這樣
試試看

1. Option Explicit
   
2. Dim 目的檔 As Workbook, 來源檔 As Workbook
   
3. Sub Copy_All()
   
4.     Dim RngAr(), Rng As Range, M As Variant, xM As Long, E As Integer, Msg As String
   
5.     With ThisWorkbook.Sheets("VBA指令")
   
6.         RngAr = .Range("G2", .Range("G2").End(xlDown)).Resize(, 3).Value   '準則範圍置於陣列變數中
   
7.     End With
   
8.     File_settings 目的檔, "ERP_Data.XLSX"
   
9.     '****  比對準則 的迴圈 **************
   
10.     For E = 1 To UBound(RngAr)
    
11.         File_settings 來源檔, RngAr(E, 1) & ""
    
12.         M = Application.Match(RngAr(E, 2), 來源檔.Sheets(1).Range("b:b"), 0)
    
13.         If IsNumeric(M) Then
    
14.             With 來源檔.Sheets(1)
    
15.                 xM = .Range("b" & M).End(xlDown).Row
    
16.                Set Rng = .Range("b" & M, .Range("b" & xM)).Resize(, Range(RngAr(E, 3)).Columns.Count)
    
17.                Rng.copy
    
18.             End With
    
19.             With 目的檔.Sheets(Mid(RngAr(E, 1), 1, 2))
    
20.                 M = Application.Match(RngAr(E, 2), .Range("c:c"), 0)
    
21.                 If IsNumeric(M) Then
    
22.                     '***貼上後範圍,會自動的反白,不須有程式碼做反白***
    
23.                     .Range("c" & M).PasteSpecial xlPasteValues
    
24.                     xM = .Range("c" & M).End(xlDown).Row  '貼上後這工作表的最後一列號
    
25.                     M = M + Rng.Rows.Count - 1            '準則列號+複製範圍的列數 - 1
    
26.                     If xM > M Then .Range("a" & M + 1, .Range("a" & xM)).EntireRow.Delete
    
27.                 Else
    
28.                     '***貼上後範圍,會自動的反白,不須有程式碼做反白***
    
29.                     .Range("c1").End(xlDown).Offset(1).PasteSpecial xlPasteValues
    
30.                 End If
    
31.             End With
    
32.             Application.CutCopyMode = False
    
33.             Msg = Msg & vbLf & Mid(RngAr(E, 1), 1, 2) & vbTab & RngAr(E, 2) & vbTab & "更新完成!"
    
34.         Else
    
35.             Msg = Msg & vbLf & Mid(RngAr(E, 1), 1, 2) & vbTab & RngAr(E, 2) & vbTab & "不用更新!"
    
36.         End If
    
37.         來源檔.Close False
    
38.     Next
    
39.     目的檔.Save     '**目的檔存檔
    
40.     MsgBox IIf(Msg = "", "沒有任何 指定訂單 更新", Mid(Msg, 2))
    
41. End Sub
    
42. '**********來源檔是同VBA報表指令的資料夾\FromERP\*********
    
43. Sub File_settings(xFile As Workbook, 工作頁 As String) '檔案設定
    
44.     Dim xPath As String
    
45.     xPath = ThisWorkbook.Path & "\"
    
46.     If UCase(工作頁) <> UCase("ERP_Data.XLSX") Then xPath = xPath & "FromERP\"
    
47.     On Error Resume Next
    
48.     Set xFile = Workbooks(工作頁)
    
49.     If Err > 0 Then Set xFile = Workbooks.Open(xPath & 工作頁)
    
50.     If xFile.Name = "" Then
    
51.         MsgBox "請查看 " & vbLf & xPath & vbLf & "是否有 [" & 工作頁 & "]"
    
52.         End
    
53.     End If
    
54. End Sub

複製代碼

PJChen

回復 19# GBKEE

GBKEE大神...執行完全沒問題.