返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2017-7-27 07:50 | 顯示全部帖子
回復 14# PJChen

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

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2017-7-28 10:41 | 顯示全部帖子
回復 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2017-7-30 07:51 | 顯示全部帖子
本帖最後由 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

        靜思自在 : 稻穗結得越飽滿，越會往下垂，一個人越有成就，就要越有謙沖的胸襟。
返回列表 上一主題