1 ...45678910111213... 19
返回列表 上一主題 發帖

[發問] 多條件篩選&ListBox

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
51# 跳轉到 »
發表於 2016-12-2 08:53 | 只看該作者
回復 50# starbox520
再麻煩仔細校對是否為 "第一種" 選項之正確答案：
a.rar (2.79 KB)
確定後，始能進行下一步驟的撰寫事宜。

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
52#
發表於 2016-12-2 09:23 | 只看該作者
回復 50# starbox520
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.    
  3.     If IsError(Target(1)) Then Unload frmSelector:         Exit Sub
  4.      
  5.     '  If (Target(1).Row + 1) Mod 5 = 0 And Target(1) <> "" And Target(1).Column = 5 Then
  6.     If (Target(1).Row + 1) Mod 5 = 0 And Target(1) <> "" And Target(1).Column = 6 Then
  7.         Set Sh_Rng = Cells(Target(1).Row, "F")

  9.         AuditCustPkg (Cells(Target(1).Row, "F"))

  11.         If IsEmpty(Sh_Ar) Then MsgBox Sh_Rng & "-" & Sh_Rng(1, 2) & vbLf & "找不到": Exit Sub
  12.         Unload frmSelector
  13.         frmSelector.Show False
  14.     Else
  15.         Unload frmSelector
  16.     End If
  17. End Sub
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
53#
發表於 2016-12-2 09:24 | 只看該作者
  1. Private Sub CustPkg(Ar3 As Variant)
  2.     Dim c As Variant, Ar As Variant, cts As Integer, tf As Boolean
  3.     Dim i As Integer, ii As Integer, frstAddr As String
  4.    
  5.     Sh_Ar = Ar
  6.    
  7.     With Sheets("工作表2")
  8.         For cts = LBound(Ar3) To UBound(Ar3)
  9.             Set c = .[A:A].Find(Ar3(cts)(0), , , 1)       '  "TR排機&產出" Customer 比對 "Cus簡碼"
  10.             '  Set c = .[A:A].Find(Ar3(1)(0), , , 1)      '  "TR排機&產出" Customer 比對 "Cus簡碼"
  11.         
  12.             If Not c Is Nothing Then
  13.                 frstAddr = c.Address
  14.                 Do
  15.                     If c.Offset(, 1) = Ar3(cts)(1) And c.Offset(, 2) = Ar3(cts)(2) Then
  16.                     '  If c.Offset(, 1) = Ar3(1)(1) And c.Offset(, 2) = Ar3(1)(2) Then
  17.                        tf = True
  18.                        If IsEmpty(Ar) Then
  19.                             ReDim Ar(1 To 8, 1 To 1)
  20.                         Else
  21.                             For i = 1 To UBound(Ar, 2)
  22.                                 If Ar(1, i) = c.Offset(, 1).Text And Ar(2, i) = c.Offset(, 2).Text And Ar(3, i) = c.Offset(, 3).Text And Ar(4, i) = c.Offset(, 4).Text Then tf = False
  23.                             Next i
  24.                             If tf Then ReDim Preserve Ar(1 To 8, 1 To UBound(Ar, 2) + 1)
  25.                         End If
  26.                         If tf Then
  27.                             For ii = 1 To 8
  28.                                 Ar(ii, UBound(Ar, 2)) = c.Offset(, ii).Text
  29.                             Next
  30.                         End If
  31.                     End If
  32.                
  33.                     Set c = .[A:A].FindNext(c)
  34.                 Loop While Not c Is Nothing And c.Address <> frstAddr
  35.             End If
  36.         Next cts        
  37.     End With
  38.    
  39.     If IsEmpty(Ar) Then Exit Sub
  40.     Sh_Ar = Application.Transpose(Ar)
  41. End Sub
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
54#
發表於 2016-12-2 09:25 | 只看該作者
本帖最後由 c_c_lai 於 2016-12-2 10:43 編輯
  1. Sub AuditCustPkg(Adt_Rng As Range)
  2.     Dim c As Range, frstAddr As String, tf As Boolean
  3.     Dim cts As Integer, ct2 As Integer
  4.     Dim Arr As Variant, Ar2 As Variant, Ar3 As Variant
  5.    
  6.     With Sheets("Cus簡碼")
  7.         Set c = .[B:B].Find(Adt_Rng.Offset(, -1).Value, , , 1)  ' "TR排機&產出" Customer 比對 "Cus簡碼" CUST_GROUP
  8.         
  9.         If Not c Is Nothing Then
  10.             frstAddr = c.Address
  11.             Do
  12.                 If IsEmpty(Arr) Then ReDim Arr(1 To 1) Else ReDim Preserve Arr(1 To UBound(Arr) + 1)
  13.                 Arr(UBound(Arr)) = Array(c.Offset(, -1).Text, c.Text)
  14.                
  15.                 Set c = .[B:B].FindNext(c)
  16.             Loop While Not c Is Nothing And c.Address <> frstAddr
  17.         End If
  18.     End With
  19.    
  20.     If Not IsEmpty(Arr) Then
  21.         With Sheets("材料")
  22.             For cts = LBound(Arr) To UBound(Arr)
  23.                 Set c = .[M:M].Find(Arr(cts)(0), , , 1)      '  "Cus簡碼" CODE 比對 "材料" CUST_CODE
  24.                
  25.                 If Not c Is Nothing Then      '  Arr(cts)(0) = "ASM" : Variant/String
  26.                     frstAddr = c.Address
  27.                     Do
  28.                         '  以 "TR排機&產出" 的  "F"、"G"、"H" 為條件，去 "材料" 找到對應的數據。
  29.                         '  第 1 種 (相同 Cust (c.Value) & PKG (c.Offset(, 3))  & B/S (c.Offset(, 4)) & L/C (c.Offset(, 5)))
  30.                         If c.Offset(, 3) = Adt_Rng.Value And c.Offset(, 4) = Adt_Rng.Offset(, 1).Value And c.Offset(, 5) = CStr(Adt_Rng.Offset(, 2).Value) Then
  31.                             If IsEmpty(Ar2) Then ReDim Ar2(1 To 1) Else ReDim Preserve Ar2(1 To UBound(Ar2) + 1)
  32.                             Ar2(UBound(Ar2)) = Array(c.Text, Arr(cts)(1), c.Offset(, 3).Text, c.Offset(, 4).Text, c.Offset(, 5).Text, c.Offset(, 39).Text, c.Offset(, 40).Text)
  33.                         End If
  34.                         
  35.                         Set c = .[M:M].FindNext(c)
  36.                     Loop While Not c Is Nothing And c.Address <> frstAddr
  37.                 End If
  38.                
  39.                 If Not IsEmpty(Ar2) Then
  40.                     For ct2 = LBound(Ar2) To UBound(Ar2)
  41.                         '  以 工作表 "TR排機&產出" 的  "F"、"G"、"H" 為條件， 去 工作表 "材料" 找到對應的數據；
  42.                         '  然後找到這筆數據的 "CARRIER1 P/N"，然後只要一樣 "CARRIER1 P/N" 的都列出來。
  43.                         Set c = .[BA:BA].Find(Ar2(ct2)(6), , , 1)   '  CARRIER1 P/N ("BA")  Ar2(ct2)(6) = "4100998111" : Variant/String
  44.                         
  45.                         If Not c Is Nothing Then   ' PKG (c.Offset(, -37)) 、 BODU_SIZE (c.Offset(, -36))
  46.                             frstAddr = c.Address   ' CUST_CODE (c.Offset(, -40).Text)、, LEAD_COUNT (c.Offset(, -35).Text)
  47.                             Do  '  "BA" 欄位指的是籃子，只要是在同個籃子內的就可以，要的就是想知道用這個籃子的有哪些人。
  48.                                 '  同步地排除原先在 工作表 "TR排機&產出" 點選的 Package。(Customer、Package、Bodysize)
  49.                                 '  修正以 "Cus簡碼" Arr 之第一組 (Arr(1)(0)) 作為判斷依據。
  50.                                 tf = (c.Offset(, -40).Text = Arr(1)(0) And c.Offset(, -37) = Adt_Rng.Value And c.Offset(, -36) = Adt_Rng.Offset(, 1).Value)
  51.                                 If Ar2(ct2)(1) <> "" And tf = False Then
  52.                                     If IsEmpty(Ar3) Then ReDim Ar3(1 To 1) Else ReDim Preserve Ar3(1 To UBound(Ar3) + 1)
  53.                                     Ar3(UBound(Ar3)) = Array(Ar2(ct2)(1), c.Offset(, -37).Text, c.Offset(, -36).Text, c.Offset(, -35).Text, c.Text)
  54.                                 End If

  56.                                 Set c = .[BA:BA].FindNext(c)
  57.                             Loop While Not c Is Nothing And c.Address <> frstAddr
  58.                         End If
  59.                     Next ct2
  60.                 End If
  61.             Next cts
  62.         End With
  63.         
  64.         If Not IsEmpty(Ar3) Then CustPkg (Ar3)
  65.     End If
  66.    
  67. Sub AuditCustPkg(Adt_Rng As Range)
  68.     Dim c As Range, frstAddr As String, tf As Boolean
  69.     Dim cts As Integer, ct2 As Integer
  70.     Dim Arr As Variant, Ar2 As Variant, Ar3 As Variant
  71.    
  72.     With Sheets("Cus簡碼")
  73.         Set c = .[B:B].Find(Adt_Rng.Offset(, -1).Value, , , 1)  ' "TR排機&產出" Customer 比對 "Cus簡碼" CUST_GROUP
  74.         
  75.         If Not c Is Nothing Then
  76.             frstAddr = c.Address
  77.             Do
  78.                 If IsEmpty(Arr) Then ReDim Arr(1 To 1) Else ReDim Preserve Arr(1 To UBound(Arr) + 1)
  79.                 Arr(UBound(Arr)) = Array(c.Offset(, -1).Text, c.Text)
  80.                
  81.                 Set c = .[B:B].FindNext(c)
  82.             Loop While Not c Is Nothing And c.Address <> frstAddr
  83.         End If
  84.     End With
  85.    
  86.     If Not IsEmpty(Arr) Then
  87.         With Sheets("材料")
  88.             For cts = LBound(Arr) To UBound(Arr)
  89.                 Set c = .[M:M].Find(Arr(cts)(0), , , 1)      '  "Cus簡碼" CODE 比對 "材料" CUST_CODE
  90.                
  91.                 If Not c Is Nothing Then      '  Arr(cts)(0) = "ASM" : Variant/String
  92.                     frstAddr = c.Address
  93.                     Do
  94.                         '  以 "TR排機&產出" 的  "F"、"G"、"H" 為條件，去 "材料" 找到對應的數據。
  95.                         '  第 1 種 (相同 Cust (c.Value) & PKG (c.Offset(, 3))  & B/S (c.Offset(, 4)) & L/C (c.Offset(, 5)))
  96.                         If c.Offset(, 3) = Adt_Rng.Value And c.Offset(, 4) = Adt_Rng.Offset(, 1).Value And c.Offset(, 5) = CStr(Adt_Rng.Offset(, 2).Value) Then
  97.                             If IsEmpty(Ar2) Then ReDim Ar2(1 To 1) Else ReDim Preserve Ar2(1 To UBound(Ar2) + 1)
  98.                             Ar2(UBound(Ar2)) = Array(c.Text, Arr(cts)(1), c.Offset(, 3).Text, c.Offset(, 4).Text, c.Offset(, 5).Text, c.Offset(, 39).Text, c.Offset(, 40).Text)
  99.                         End If
  100.                         
  101.                         Set c = .[M:M].FindNext(c)
  102.                     Loop While Not c Is Nothing And c.Address <> frstAddr
  103.                 End If
  104.                
  105.                 If Not IsEmpty(Ar2) Then
  106.                     For ct2 = LBound(Ar2) To UBound(Ar2)
  107.                         '  以 工作表 "TR排機&產出" 的  "F"、"G"、"H" 為條件， 去 工作表 "材料" 找到對應的數據；
  108.                         '  然後找到這筆數據的 "CARRIER1 P/N"，然後只要一樣 "CARRIER1 P/N" 的都列出來。
  109.                         Set c = .[BA:BA].Find(Ar2(ct2)(6), , , 1)   '  CARRIER1 P/N ("BA")  Ar2(ct2)(6) = "4100998111" : Variant/String
  110.                         
  111.                         If Not c Is Nothing Then   ' PKG (c.Offset(, -37)) 、 BODU_SIZE (c.Offset(, -36))
  112.                             frstAddr = c.Address   ' CUST_CODE (c.Offset(, -40).Text)、, LEAD_COUNT (c.Offset(, -35).Text)
  113.                             Do  '  "BA" 欄位指的是籃子，只要是在同個籃子內的就可以，要的就是想知道用這個籃子的有哪些人。
  114.                                 '  同步地排除原先在 工作表 "TR排機&產出" 點選的 Package。(Customer、Package、Bodysize)
  115.                                 '  修正以 "Cus簡碼" Arr 之第一組 (Arr(1)(0)) 作為判斷依據。
  116.                                 tf = (c.Offset(, -40).Text = Arr(1)(0) And c.Offset(, -37) = Adt_Rng.Value And c.Offset(, -36) = Adt_Rng.Offset(, 1).Value)
  117.                                 If Ar2(ct2)(1) <> "" And tf = False Then
  118.                                     If IsEmpty(Ar3) Then ReDim Ar3(1 To 1) Else ReDim Preserve Ar3(1 To UBound(Ar3) + 1)
  119.                                     Ar3(UBound(Ar3)) = Array(Ar2(ct2)(1), c.Offset(, -37).Text, c.Offset(, -36).Text, c.Offset(, -35).Text, c.Text)
  120.                                 End If

  122.                                 Set c = .[BA:BA].FindNext(c)
  123.                             Loop While Not c Is Nothing And c.Address <> frstAddr
  124.                         End If
  125.                     Next ct2
  126.                 End If
  127.             Next cts
  128.         End With
  129.         
  130.         If Not IsEmpty(Ar3) Then CustPkg (Ar3)
  131.     End If
  132.    
  133.     Set Arr = Nothing
  134.     Set Ar2 = Nothing
  135.     Set Ar3 = Nothing
  136. End Sub
複製代碼

a.rar (2.79 KB)

TOP

starbox520

帖子
192 
主題
15 
精華
0 
積分
194 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
女 
註冊時間
2016-9-22 
最後登錄
2020-8-28 

論壇榮譽勳章論壇贊助勳章
55#
發表於 2016-12-2 10:39 | 只看該作者
回復 54# c_c_lai


    沒錯!!!!
    第一種篩法結果是對的!!!!太厲害了C大!!!!

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
56#
發表於 2016-12-2 10:45 | 只看該作者
回復 55# starbox520
妳將我目前修正的程式碼套入你的程式中，
跑一次看看結果是否如你所願？

TOP

starbox520

帖子
192 
主題
15 
精華
0 
積分
194 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
女 
註冊時間
2016-9-22 
最後登錄
2020-8-28 

論壇榮譽勳章論壇贊助勳章
57#
發表於 2016-12-2 13:47 | 只看該作者
回復 56# c_c_lai


   
     那ㄟ安捏...
  1. Sub AuditCustPkg(Adt_Rng As Range)
  2.     Dim c As Range, frstAddr As String, tf As Boolean
  3.     Dim cts As Integer, ct2 As Integer
  4.     Dim Arr As Variant, Ar2 As Variant, Ar3 As Variant
  5.    
  6.     With Sheets("Cus簡碼")
  7.         Set c = .[B:B].Find(Adt_Rng.Offset(, -1).Value, , , 1)  ' "TR排機&產出" Customer 比對 "Cus簡碼" CUST_GROUP
  8.         
  9.         If Not c Is Nothing Then
  10.             frstAddr = c.Address
  11.             Do
  12.                 If IsEmpty(Arr) Then ReDim Arr(1 To 1) Else ReDim Preserve Arr(1 To UBound(Arr) + 1)
  13.                 Arr(UBound(Arr)) = Array(c.Offset(, -1).Text, c.Text)
  14.                
  15.                 Set c = .[B:B].FindNext(c)
  16.             Loop While Not c Is Nothing And c.Address <> frstAddr
  17.         End If
  18.     End With
  19.    
  20.     If Not IsEmpty(Arr) Then
  21.         With Sheets("材料")
  22.             For cts = LBound(Arr) To UBound(Arr)
  23.                 Set c = .[M:M].Find(Arr(cts)(0), , , 1)      '  "Cus簡碼" CODE 比對 "材料" CUST_CODE
  24.                
  25.                 If Not c Is Nothing Then      '  Arr(cts)(0) = "ASM" : Variant/String
  26.                     frstAddr = c.Address
  27.                     Do
  28.                         '  以 "TR排機&產出" 的  "F"、"G"、"H" 為條件，去 "材料" 找到對應的數據。
  29.                         '  第 1 種 (相同 Cust (c.Value) & PKG (c.Offset(, 3))  & B/S (c.Offset(, 4)) & L/C (c.Offset(, 5)))
  30.                         If c.Offset(, 3) = Adt_Rng.Value And c.Offset(, 4) = Adt_Rng.Offset(, 1).Value And c.Offset(, 5) = CStr(Adt_Rng.Offset(, 2).Value) Then
  31.                             If IsEmpty(Ar2) Then ReDim Ar2(1 To 1) Else ReDim Preserve Ar2(1 To UBound(Ar2) + 1)
  32.                             Ar2(UBound(Ar2)) = Array(c.Text, Arr(cts)(1), c.Offset(, 3).Text, c.Offset(, 4).Text, c.Offset(, 5).Text, c.Offset(, 39).Text, c.Offset(, 40).Text)
  33.                         End If
  34.                         
  35.                         Set c = .[M:M].FindNext(c)
  36.                     Loop While Not c Is Nothing And c.Address <> frstAddr
  37.                 End If
  38.                
  39.                 If Not IsEmpty(Ar2) Then
  40.                     For ct2 = LBound(Ar2) To UBound(Ar2)
  41.                         '  以 工作表 "TR排機&產出" 的  "F"、"G"、"H" 為條件， 去 工作表 "材料" 找到對應的數據；
  42.                         '  然後找到這筆數據的 "CARRIER1 P/N"，然後只要一樣 "CARRIER1 P/N" 的都列出來。
  43.                         Set c = .[BA:BA].Find(Ar2(ct2)(6), , , 1)   '  CARRIER1 P/N ("BA")  Ar2(ct2)(6) = "4100998111" :
  44.                         
  45.                         If Not c Is Nothing Then   ' PKG (c.Offset(, -37)) 、 BODU_SIZE (c.Offset(, -36))
  46.                             frstAddr = c.Address   ' CUST_CODE (c.Offset(, -40).Text)、, LEAD_COUNT (c.Offset(, -35).Text)
  47.                             Do
  48.                                 '  同步地排除原先在 工作表 "TR排機&產出" 點選的 Package。(Customer、Package、Bodysize)
  49.                                 '  修正以 "Cus簡碼" Arr 之第一組 (Arr(1)(0)) 作為判斷依據。
  50.                                 tf = (c.Offset(, -40).Text = Arr(1)(0) And c.Offset(, -37) = Adt_Rng.Value And c.Offset(, -36) = Adt_Rng.Offset(, 1).Value)
  51.                                 If Ar2(ct2)(1) <> "" And tf = False Then
  52.                                     If IsEmpty(Ar3) Then ReDim Ar3(1 To 1) Else ReDim Preserve Ar3(1 To UBound(Ar3) + 1)
  53.                                     Ar3(UBound(Ar3)) = Array(Ar2(ct2)(1), c.Offset(, -37).Text, c.Offset(, -36).Text, c.Offset(, -35).Text, c.Text)
  54.                                 End If

  56.                                 Set c = .[BA:BA].FindNext(c)
  57.                             Loop While Not c Is Nothing And c.Address <> frstAddr
  58.                         End If
  59.                     Next ct2
  60.                 End If
  61.             Next cts
  62.         End With
  63.         
  64.         If Not IsEmpty(Ar3) Then CustPkg (Ar3)
  65.     End If
  66.    
  67.     Set Arr = Nothing
  68.     Set Ar2 = Nothing
  69.     Set Ar3 = Nothing
  70. End Sub
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
58#
發表於 2016-12-2 14:19 | 只看該作者
回復 57# starbox520
三支程式皆應放入到 工作表單 "TR排機&產出" 內，
如不行妳將妳的程式上傳，我來幫妳整理。

TOP

starbox520

帖子
192 
主題
15 
精華
0 
積分
194 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
女 
註冊時間
2016-9-22 
最後登錄
2020-8-28 

論壇榮譽勳章論壇贊助勳章
59#
發表於 2016-12-2 14:37 | 只看該作者
回復 58# c_c_lai

     對啊我放在裡面耶><

    TTS0000CC.rar (805.86 KB)

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
60#
發表於 2016-12-2 15:21 | 只看該作者
回復 59# starbox520
妳將 AuditCustPkg(Adt_Rng As Range) 重複貼置，
AuditCustPkg(Adt_Rng As Range) 內又有一個
AuditCustPkg(Adt_Rng As Range)。
TTS0000CC.rar (816.07 KB)

TOP

        靜思自在 : 口說好話、心想好意、身行好事。
1 ...45678910111213... 19
返回列表 上一主題