- 帖子
- 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
|
|
