返回列表 上一主題 發帖

[發問] 多條件篩選&ListBox

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
1# 跳轉到 »
發表於 2016-12-5 16:31 | 顯示全部帖子
回復 81# starbox520
參考看看:
  1. Sub Test()
  2.     Dim v
  3.     v = GetMyData("SYNAPTICS", "BGA", "17.3X7", 36)
  4.     Stop
  5. End Sub
複製代碼
新增模組
  1. Private arMaterial, arSh2
  2. Private dResult As Object

  4. Function GetMyData(cus, pkg, size, lc)
  5.     ReadFromSheet
  6.    
  7.     Method1 cus, pkg, size, lc
  8.     Method2 cus, pkg, size, lc
  9.    
  10.     Dim ar
  11.     If dResult.Count > 0 Then
  12.         ar = Application.Transpose(Application.Transpose(dResult.items))
  13.     End If
  14.     GetMyData = ar
  15.    
  16.     Erase arMaterial
  17.     Erase arSh2
  18.     Set dResult = Nothing
  19. End Function

  21. Sub ReadFromSheet()
  22.     Set dResult = CreateObject("scripting.dictionary")
  23.     '讀到 array 中
  24.     With Sheets("工作表2")
  25.         arSh2 = .[a1].CurrentRegion.Value
  26.     End With
  27.     With Sheets("材料")
  28.         arMaterial = .[a1].CurrentRegion.Value
  29.     End With
  30.    
  31.     '建立簡碼對應全名的字典
  32.     Dim ar, dCustCode As Object
  33.     Set dCustCode = CreateObject("scripting.dictionary")
  34.     With Sheets("Cus簡碼")
  35.         ar = .[a1].CurrentRegion.Value
  36.     End With
  37.     For i = 2 To UBound(ar): dCustCode(ar(i, 1)) = ar(i, 2): Next
  38.    
  39.     ' 將 arMaterial 中取代 簡碼為全名
  40.     For i = 2 To UBound(arMaterial)
  41.         If dCustCode.exists(arMaterial(i, 13)) Then
  42.             arMaterial(i, 13) = dCustCode(arMaterial(i, 13))
  43.         End If
  44.     Next
  45. End Sub

  47. Function Method1(cus, pkg, size, lc)
  48.     '找出 match 的CARRIER1 P/N
  49.     Dim dPN As Object: Set dPN = CreateObject("scripting.dictionary")
  50.     For i = 2 To UBound(arMaterial)
  51.         'M、P、Q、R ， find BA
  52.         If StrComp(cus, arMaterial(i, 13), vbTextCompare) = 0 And _
  53.             StrComp(pkg, arMaterial(i, 16), vbTextCompare) = 0 And _
  54.             StrComp(size, arMaterial(i, 17), vbTextCompare) = 0 And _
  55.             StrComp(lc, arMaterial(i, 18), vbTextCompare) = 0 Then
  56.             dPN(arMaterial(i, 53)) = 0
  57.         End If
  58.     Next
  59.    
  60.     Dim ar, key
  61.     For i = 2 To UBound(arMaterial)
  62.         If dPN.exists(arMaterial(i, 53)) Then
  63.             For j = 2 To UBound(arSh2)
  64.                 'M、P、Q、R <-> A、B、C、D
  65.                 If StrComp(arMaterial(i, 13), arSh2(j, 1), vbTextCompare) = 0 And _
  66.                     StrComp(arMaterial(i, 16), arSh2(j, 2), vbTextCompare) = 0 And _
  67.                     StrComp(arMaterial(i, 17), arSh2(j, 3), vbTextCompare) = 0 And _
  68.                     StrComp(arMaterial(i, 18), arSh2(j, 4), vbTextCompare) = 0 Then
  69.                     If Not dResult.exists(j) Then dResult.Add j, Array(arSh2(j, 1), arSh2(j, 2), arSh2(j, 3), arSh2(j, 4), arSh2(j, 5), arSh2(j, 6), arSh2(j, 7), arSh2(j, 8), "1")
  70.                 End If
  71.             Next
  72.         End If
  73.     Next
  74. End Function
  75. Function Method2(cus, pkg, size, lc)
  76.     '找出 match 的 Width
  77.     Dim dPN As Object: Set dPN = CreateObject("scripting.dictionary")
  78.     For i = 2 To UBound(arMaterial)
  79.         'M、P、Q、R ， find AZ
  80.         If StrComp(cus, arMaterial(i, 13), vbTextCompare) = 0 And _
  81.             StrComp(pkg, arMaterial(i, 16), vbTextCompare) = 0 And _
  82.             StrComp(size, arMaterial(i, 17), vbTextCompare) = 0 And _
  83.             StrComp(lc, arMaterial(i, 18), vbTextCompare) = 0 Then
  84.             dPN(arMaterial(i, 52)) = 0
  85.         End If
  86.     Next
  87.    
  88.     Dim ar, key
  89.     For i = 2 To UBound(arMaterial)
  90.         If dPN.exists(arMaterial(i, 52)) Then
  91.             For j = 2 To UBound(arSh2)
  92.                 'M、P、Q、R <-> A、B、C、D
  93.                 If StrComp(arMaterial(i, 13), arSh2(j, 1), vbTextCompare) = 0 And _
  94.                     StrComp(arMaterial(i, 16), arSh2(j, 2), vbTextCompare) = 0 And _
  95.                     StrComp(arMaterial(i, 17), arSh2(j, 3), vbTextCompare) = 0 And _
  96.                     StrComp(arMaterial(i, 18), arSh2(j, 4), vbTextCompare) = 0 Then
  97.                     If Not dResult.exists(j) Then dResult.Add j, Array(arSh2(j, 1), arSh2(j, 2), arSh2(j, 3), arSh2(j, 4), arSh2(j, 5), arSh2(j, 6), arSh2(j, 7), arSh2(j, 8), "2")
  98.                 End If
  99.             Next
  100.         End If
  101.     Next
  102. End Function
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

        靜思自在 : 站在半路，比走到目標更辛苦。
返回列表 上一主題