123
返回列表 上一主題 發帖

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

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
12# 跳轉到 »
發表於 2017-7-25 10:06 | 只看該作者
本帖最後由 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

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
11#
發表於 2017-7-16 14:54 | 只看該作者
回復 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

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
10#
發表於 2017-7-16 01:06 | 只看該作者
回復 7# Hsieh

我自己修改了程式但沒有貼的動作,請問
Row.Count要如何數？Offset(1)又代表什麼？
還有第二行的程式要怎麼解讀？
  1. If a Is Nothing Then Set a = .Cells(.Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
  2.        .Range("A" & a.Row & ":AA" & .Rows.Count).ClearContents
複製代碼

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
9#
發表於 2017-7-15 23:55 | 只看該作者
回復 7# Hsieh
大大,
我修改了些小地方,現在貼上時正常了.
  1. Sub copy_all()
  2. Dim ws() '已經開啟視窗
  3. books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
  4. mypath = ThisWorkbook.Path '存放檔案資料夾
  5. For Each W In Windows '已經開啟視窗
  6.    ReDim Preserve ws(s)
  7.    ws(s) = W.Caption
  8.    s = s + 1
  9. Next
  10. For Each b In books '測試檔案是否開啟
  11.    If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
  12. Next
  13. x = ThisWorkbook.Sheets(1).[H2] '準則
  14. With Workbooks(books(0)).Sheets(1) '庫存資料表.xlsx
  15.     Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
  16.     If a Is Nothing Then MsgBox "找不到準則位置": End
  17.     Set Rng = .Range(a.Offset(, -3), a.End(xlDown).Offset(, 23)) 'B:AA欄資料
  18.     'MsgBox Rng.Address
  19.     With Workbooks(books(1)).Sheets(1) '庫存.xlsx
  20.        Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
  21.        If a Is Nothing Then Set a = .Cells(.Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
  22.        .Range("A" & a.Row & ":AA" & .Rows.Count).ClearContents
  23.           a.Offset(, -3).Resize(Rng.Rows.Count, 27).Value = Rng.Value '寫入新資料
  24.           'a.Offset(, -3).Resize(Rng.Rows.Count, 1) = Rng.Columns(5).Value '寫入A欄編號
  25.           MsgBox "資料已更新"
  26.     End With
  27. End With
  28. End Sub
複製代碼

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
8#
發表於 2017-7-14 23:38 | 只看該作者
回復 7# Hsieh

大大,
1) 經測試,貼資料的時候,它會把AA欄的資料貼到A欄,然後其他資料向右移一個欄位....請問要如何修正?
2) 因為這個程式,我還會使用在其他的文件上，books = Array("庫存資料表.xlsx", "庫存.xlsx"),是否檔名不同時,我只要改不同顏色的檔名即可？其他檔名如程式中的Sheets(1)我不用動它,是嗎？
3) 當我的檔案存放路徑不同時,我需要修改什麼地方嗎？
4) 但每份報表的貼上位置不同,如果我要自己修改，以VBA報表指令.xlsm的VBA指令.sheet H2儲存格為搜尋準則去搜尋目的檔C欄,但是貼上要在B欄,我要怎麼修改?

不好意思,麻煩你了...

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
125  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-6-1 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2017-7-13 11:40 | 只看該作者
回復 6# PJChen
  1. Sub copy_all()
  2. Dim ws() '已經開啟視窗
  3. books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
  4. mypath = ThisWorkbook.Path '存放檔案資料夾
  5. For Each w In Windows '已經開啟視窗
  6.    ReDim Preserve ws(s)
  7.    ws(s) = w.Caption
  8.    s = s + 1
  9. Next
  10. For Each b In books '測試檔案是否開啟
  11.    If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
  12. Next
  13. x = ThisWorkbook.Sheets(1).[H2] '準則
  14. With Workbooks(books(0)).Sheets(1) '庫存資料表.xlsx
  15.     Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
  16.     If a Is Nothing Then MsgBox "找不到準則位置": End
  17.     Set Rng = .Range(a.Offset(, -2), a.End(xlDown).Offset(, 23)) 'B:AA欄資料
  18.     MsgBox Rng.Address
  19.     With Workbooks(books(1)).Sheets(1) '庫存.xlsx
  20.        Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
  21.        If a Is Nothing Then Set a = .Cells(.Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
  22.        .Range("A" & a.Row & ":AA" & .Rows.Count).ClearContents
  23.           a.Offset(, -2).Resize(Rng.Rows.Count, 26).Value = Rng.Value '寫入新資料
  24.           a.Offset(, -3).Resize(Rng.Rows.Count, 1) = Rng.Columns(5).Value '寫入A欄編號
  25.           MsgBox "資料已更新"
  26.     End With
  27. End With
  28. End Sub
複製代碼
學海無涯_不恥下問

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
6#
發表於 2017-7-11 23:44 | 只看該作者
回復 5# Hsieh

大大,

我測試了幾次,發現一些問題,要再麻煩您修改下.

1. 在測試的時候,我故意把"庫存.xlsx"的資料刪除,只保留至1000列.
2. "庫存資料表"共1059列(都沒有刪除), 當我把"VBA報表指令.xlsm" H2的變數改為M1時,它應該要從"庫存資料表"的A1:AA1059複製到"庫存.xlsx"的A1:AA1059貼滿,但它只詢問有9列新資料是否要更新.
3. 當我把"庫存.xlsx"的資料A欄資料保留10列,其餘A11以後為空白時，它也無法正常更新資料

P.S. 大大寫的程式因為不是巨集式的,我有看沒有懂,您可否幫我註解再更詳細些，因為這個程式,我會應用到很多資料上，詳細的註解有助於我日後的小修改.  
附上我測試的檔案 依變數搜尋資料2.rar (298.47 KB)

先謝謝了.

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
125  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-6-1 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2017-7-11 11:26 | 只看該作者
回復 4# PJChen

參考看看
  1. Sub copy_all()
  2. Dim ws() '已經開啟視窗
  3. books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
  4. mypath = ThisWorkbook.Path '存放檔案資料夾
  5. For Each w In Windows '已經開啟視窗
  6.    ReDim Preserve ws(s)
  7.    ws(s) = w.Caption
  8.    s = s + 1
  9. Next
  10. For Each b In books '測試檔案是否開啟
  11.    If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
  12. Next
  13. x = ThisWorkbook.Sheets(1).[H2] '準則
  14. With Workbooks(books(0)) '庫存資料表.xlsx
  15.     Set a = .Sheets(1).Columns("D").Find(x, lookat:=xlWhole) '找準則位置
  16.     If a Is Nothing Then MsgBox "找不到準則位置": End
  17.     k = Application.CountIf(a.EntireColumn, x) '合乎準則列數
  18.     Set Rng = .Sheets(1).Cells(a.Row, "B").Resize(k, 26) 'B:AA欄資料
  19.     With Workbooks(books(1)) '庫存.xlsx
  20.        k1 = Application.CountIf(.Sheets(1).Columns("D"), x) '合乎準則列數
  21.        Set a = .Sheets(1).Columns("D").Find(x, lookat:=xlWhole) '找準則位置
  22.        If a Is Nothing Then Set a = .Sheets(1).Cells(.Sheets(1).Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
  23.        yn = MsgBox("原資料" & k1 & "列，新資料" & k & "列，是否複製?", vbYesNo)
  24.        If yn = 6 Then
  25.           a.Offset(, -2).Resize(k, 26).Value = Rng.Value '寫入新資料
  26.           MsgBox "資料已更新"
  27.         Else
  28.           MsgBox "資料未更新", 48
  29.        End If
  30.     End With
  31. End With
  32. End Sub
複製代碼
學海無涯_不恥下問

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
4#
發表於 2017-7-10 18:14 | 只看該作者
回復 3# Hsieh

大大好,

我抓的報表日期區間可能就是當月份的,Excel檔中的資料會累積比較多資料,所以我在VBA報表指令.xlsm H2中指定一個單號名稱,而一個單號可能有很多筆,所以我要指定它可以從找到的第一筆開始貼上,這樣就不會蓋掉我需要的資料,同時也可以更新我要的資料.

只是我手上正好有這個資料,所以就偷懶用這個檔來詢問,不過觀念是相同的.

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
125  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-6-1 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2017-7-10 14:13 | 只看該作者
回復 2# PJChen

貼上的位置是庫存檔案的位置，若原來庫存的筆數不同該如何處理?
若筆數相同就會直接覆蓋原有資料，這是你的需求嗎?
若筆數教員資料多，則會影響不同準則的資料，這些跟庫存觀念好像都不符合
學海無涯_不恥下問

TOP

        靜思自在 : 能付出愛心就是福，能消除煩惱就是慧。
123
返回列表 上一主題