多條件篩選&ListBox - Excel程式區 - 麻辣家族討論版版

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

論壇榮譽勳章論壇贊助勳章

81^# 跳轉到 »

發表於 2016-12-5 12:01 | 只看該作者

回復 80# c_c_lai

謝謝妳耐心地回答。再次求解答：
第一種 (By "Carrier1 PIN") 篩選後的內容假設是如下之組合情形？

ATM       AT             TQFP       14X14       64             32             4101149111
ATM       AT             TQFP       14X14       1000          32             4101149111
ATM       AT             TQFP       14X14       64             24             4101149111
ATM       AT             BGA       14X14       68             32             4101149111
AMD                         TQFP       14X20       44             16             4101149111
MRS                         TQFP       14X14       64             32             4101149111

回C大這裡是只篩選Carrier1 PIN的部分的話
每一個資訊都是正確答案!!! 只是因為對照到"工作表2"有些資料會在"工作表2"找不到
找不到的就當成在進行工作表2篩選時被淘汰了
所以人工方法，要一個一個對"CUS簡碼"，然後又要一個一個對"工作表2"

Width也是一樣

TOP

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

82^#

發表於 2016-12-5 16:31 | 只看該作者

回復 81# starbox520
參考看看:

Sub Test()
Dim v
v = GetMyData("SYNAPTICS", "BGA", "17.3X7", 36)
Stop
End Sub

複製代碼

新增模組

Private arMaterial, arSh2
Private dResult As Object
Function GetMyData(cus, pkg, size, lc)
ReadFromSheet
Method1 cus, pkg, size, lc
Method2 cus, pkg, size, lc
Dim ar
If dResult.Count > 0 Then
ar = Application.Transpose(Application.Transpose(dResult.items))
End If
GetMyData = ar
Erase arMaterial
Erase arSh2
Set dResult = Nothing
End Function
Sub ReadFromSheet()
Set dResult = CreateObject("scripting.dictionary")
'讀到 array 中
With Sheets("工作表2")
arSh2 = .[a1].CurrentRegion.Value
End With
With Sheets("材料")
arMaterial = .[a1].CurrentRegion.Value
End With
'建立簡碼對應全名的字典
Dim ar, dCustCode As Object
Set dCustCode = CreateObject("scripting.dictionary")
With Sheets("Cus簡碼")
ar = .[a1].CurrentRegion.Value
End With
For i = 2 To UBound(ar): dCustCode(ar(i, 1)) = ar(i, 2): Next
' 將 arMaterial 中取代簡碼為全名
For i = 2 To UBound(arMaterial)
If dCustCode.exists(arMaterial(i, 13)) Then
arMaterial(i, 13) = dCustCode(arMaterial(i, 13))
End If
Next
End Sub
Function Method1(cus, pkg, size, lc)
'找出 match 的CARRIER1 P/N
Dim dPN As Object: Set dPN = CreateObject("scripting.dictionary")
For i = 2 To UBound(arMaterial)
'M、P、Q、R ， find BA
If StrComp(cus, arMaterial(i, 13), vbTextCompare) = 0 And _
StrComp(pkg, arMaterial(i, 16), vbTextCompare) = 0 And _
StrComp(size, arMaterial(i, 17), vbTextCompare) = 0 And _
StrComp(lc, arMaterial(i, 18), vbTextCompare) = 0 Then
dPN(arMaterial(i, 53)) = 0
End If
Next
Dim ar, key
For i = 2 To UBound(arMaterial)
If dPN.exists(arMaterial(i, 53)) Then
For j = 2 To UBound(arSh2)
'M、P、Q、R <-> A、B、C、D
If StrComp(arMaterial(i, 13), arSh2(j, 1), vbTextCompare) = 0 And _
StrComp(arMaterial(i, 16), arSh2(j, 2), vbTextCompare) = 0 And _
StrComp(arMaterial(i, 17), arSh2(j, 3), vbTextCompare) = 0 And _
StrComp(arMaterial(i, 18), arSh2(j, 4), vbTextCompare) = 0 Then
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")
End If
Next
End If
Next
End Function
Function Method2(cus, pkg, size, lc)
'找出 match 的 Width
Dim dPN As Object: Set dPN = CreateObject("scripting.dictionary")
For i = 2 To UBound(arMaterial)
'M、P、Q、R ， find AZ
If StrComp(cus, arMaterial(i, 13), vbTextCompare) = 0 And _
StrComp(pkg, arMaterial(i, 16), vbTextCompare) = 0 And _
StrComp(size, arMaterial(i, 17), vbTextCompare) = 0 And _
StrComp(lc, arMaterial(i, 18), vbTextCompare) = 0 Then
dPN(arMaterial(i, 52)) = 0
End If
Next
Dim ar, key
For i = 2 To UBound(arMaterial)
If dPN.exists(arMaterial(i, 52)) Then
For j = 2 To UBound(arSh2)
'M、P、Q、R <-> A、B、C、D
If StrComp(arMaterial(i, 13), arSh2(j, 1), vbTextCompare) = 0 And _
StrComp(arMaterial(i, 16), arSh2(j, 2), vbTextCompare) = 0 And _
StrComp(arMaterial(i, 17), arSh2(j, 3), vbTextCompare) = 0 And _
StrComp(arMaterial(i, 18), arSh2(j, 4), vbTextCompare) = 0 Then
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")
End If
Next
End If
Next
End Function