返回列表 上一主題 發帖

[發問] 搜尋符合條件的訂單號碼

回復 7# Hsieh

大大,

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

來源檔 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. 當資料貼完以後,要再隱藏群組

TOP

本帖最後由 GBKEE 於 2017-7-27 07:45 編輯

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 12# GBKEE


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


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

TOP

回復 13# PJChen

大大,

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

Try_20170726.part1.rar (600 KB)
Try_20170726.part2.rar (463.64 KB)

TOP

回復 14# PJChen

12#的程式碼,今天已更新,請重試看看,準則複製到目的檔有用紅框框上.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 15# GBKEE

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

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

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

Try_20170727.part1.rar (600 KB) Try_20170727.part2.rar (466.57 KB)

TOP

回復 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. 多餘的資料無法刪除,我不確定新的程式是否沒有這個功能?
  還沒,請問如何判斷多餘的資料
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

本帖最後由 PJChen 於 2017-7-29 19:56 編輯

回復 17# GBKEE

大大,

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

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


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


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


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


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

TOP

本帖最後由 GBKEE 於 2017-7-30 07:53 編輯

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 19# GBKEE

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

TOP

        靜思自在 : 要用心,不要操心、煩心。
返回列表 上一主題