返回列表 上一主題 發帖

[發問] 列出更多的對應資料

尋找目標只有一個, 用篩選再貼即可

TOP

簡化不了,
Sub TEST()
Dim Arr, xD, i&, j%, N&, T$, V%
Set xD = CreateObject("scripting.dictionary")
Arr = Range([目標!C1], [目標!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    For j = 1 To 3 Step 2
        T = Arr(i, j):  If T <> "" Then xD(T) = 1
        If T Like "*-*-*" Then xD(Left(T, InStrRev(T, "-") - 1)) = 1
    Next j
Next i
Arr = Range([庫存!D1], [庫存!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    For j = 1 To 3 Step 2
        T = Arr(i, j):  V = V + xD(T)
        If T Like "*-*-*" Then V = V + xD(Left(T, InStrRev(T, "-") - 1))
    Next j
    If V = 0 Then GoTo 101
    N = N + 1: V = 0
    For j = 1 To 4: Arr(N, j) = Arr(i, j): Next
101: Next i
[成果!A2:A6000].ClearContents
If N > 0 Then [成果!A2:D2].Resize(N) = Arr
End Sub


============================

TOP

回復 9# qaqa3296


不了解少資料是何意???
根據描述, 將規格 231-215-??? 第三字節去除, 做為另一比對條件,
文字前後若含有空白字元, 套一個TRIM(ARR(i,3)) 即可~~
100-1001.3.V1 這個是否還要取出 100-1001 做為條件,
多列出幾個不同型式的規格文字, 及其截取規則~~~

或者, 規格的前8碼為固定共用, 之後的為變化形, 都視為相同???

TOP

這種文字比對太費周折,
看看是否如下規則, 若有其它, 再補充
拆碼原則.rar (2.37 KB)

可能沒空幫忙寫~~

TOP

本帖最後由 准提部林 於 2020-8-22 15:05 編輯

測試資料太少, 無法多做驗證:
Sub TEST_V1()
Dim Arr, A, xD, i&, j%, N&, T$, V%
[成果!A2:D6000].ClearContents
Set xD = CreateObject("scripting.dictionary")
Arr = Range([目標!C1], [目標!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    T = Trim(Arr(i, 1)): If T <> "" Then xD(T) = 1
    T = 拆解編號(Trim(Arr(i, 3))): If T = "" Then GoTo 101
    For Each A In Split(T, "/"): xD(A & "") = 1: Next
101: Next i
Arr = Range([庫存!D1], [庫存!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    If xD("|" & i) > 0 Then GoTo 102 '如果該行已被提取過, 略過, 避免重覆提取
    T = Trim(Arr(i, 1)): If xD(T) > 0 Then V = 1: GoTo 999 '[品號]相符即直接提取
    T = Trim(Arr(i, 3)): If T = "" Then GoTo 102
    T = 拆解編號(T) '拆解[規格]
    For Each A In Split(T, "/")
        If xD(A & "") > 0 Then V = 1: Exit For
    Next
999:
   If V = 0 Then GoTo 102
   N = N + 1: V = 0
   For j = 1 To 4: Arr(N, j) = Trim(Arr(i, j)): Next
   xD("|" & i) = 1 '已提取行號位置,記錄入字典
102: Next i
If N > 0 Then [成果!A2:D2].Resize(N) = Arr
End Sub

'==========================================
Function 拆解編號(xS$) As String
Dim TT$, j%, ST$
If xS = "" Then Exit Function
If xS & "-" Like "####[-.]*" Then TT = Left(xS, 4)
If xS & "A" Like "####[A-Z]*" Then TT = Left(xS, 4)
If xS & "-" Like "?????[-.]*" Then TT = Left(xS, 5)
If xS & "-" Like "???-????[-.]*" Then TT = Left(xS, 8)
xS = xS & "-"
For j = Len(TT) + 2 To Len(xS)
    If Mid(xS, j, 1) Like "[-.]" Then TT = Left(xS, j - 1) & "/" & TT
Next j
拆解編號 = TT
End Function


'全部貼入模組===============================================

TOP

Sub TEST_V1()
Dim Arr, A, xD, i&, j%, N&, T$, V%
[成果!A2:D6000].ClearContents
Set xD = CreateObject("scripting.dictionary")
Arr = Range([目標!C1], [目標!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    T = Trim(Arr(i, 1)): If T <> "" Then xD(T) = 1
    T = 拆解編號(Trim(Arr(i, 3))): If T = "" Then GoTo 101
    For Each A In Split(T, "/"): xD(A & "") = 1: Next
101: Next i
Arr = Range([庫存!D1], [庫存!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    If xD("|" & i) > 0 Then GoTo 102 '如果該行已被提取過, 略過, 避免重覆提取
    T = Trim(Arr(i, 1)): If Val(xD(T)) > 0 Then V = 1: GoTo 999 '[品號]相符即直接提取
    T = Trim(Arr(i, 3)): If T = "" Then GoTo 102
    T = 拆解編號(T) '拆解[規格]
    For Each A In Split(T, "/")
        If A <> "" And Val(xD(A & "")) > 0 Then V = 1: Exit For
    Next
999:
   If V = 0 Then GoTo 102
   N = N + 1: V = 0
   For j = 1 To 4: Arr(N, j) = Trim(Arr(i, j)): Next
   xD("|" & i) = 1 '已提取行號位置,記錄入字典
102: Next i
If N > 0 Then [成果!A2:D2].Resize(N) = Arr
End Sub

'==========================================
Function 拆解編號(xS$) As String
Dim TT$, j%, ST$
If xS = "" Then Exit Function
If Left(xS, 4) Like "####" Then TT = Left(xS, 4)
If Left(xS, 5) Like "####[A-Z]" Then TT = Left(xS, 5) & "/" & TT
If Left(xS, 5) Like "[A-Z]####" Then TT = Left(xS, 5) & "/" & TT
If Left(xS, 8) Like "???-????" Then TT = Left(xS, 8) & "/" & TT
xS = xS & "-"
For j = Len(TT) + 2 To Len(xS)
    If Mid(xS, j, 1) Like "[-.(]" Then TT = Left(xS, j - 1) & "/" & TT
Next j
拆解編號 = TT
End Function

模糊中又不能亂抓, 難~~~

TOP

回復 59# 軒云熊


dic--keys, items
keys--只會留獨一無二的"索引值", 所以不會重覆
items--可以容納任何型態內容, 變化較多, 但可從簡單的著手

其實很好理解, 多幾次練習即可,
單欄資料:
1) 取得a欄內容的唯一值
2) 計算a欄各唯一值的出現次數
兩欄資料:
1) 計算a欄各唯一值在b欄的合計數
2) 計算a欄各唯一值,且b欄符合某一條件的次數

TOP

回復 61# 軒云熊


論壇有很多例子可參考~~
或到這多學習, 有現成較新的帖子當參考:
http://club.excelhome.net/forum-2-1.html

TOP

        靜思自在 : 生氣,就是拿別人的過錯來懲罰自己。
返回列表 上一主題