准提部林

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

下載次數: 10

2020-8-22 10:08

可能沒空幫忙寫~~

qaqa3296

回復 軒云熊 你的程式不知是電腦太慢還是...? 當掉了

回復n7822123
程式真的是淺顯易懂超級入門

定義與修改真的很方便，也讓我了解到原來可以定義可以到如此細膩簡單

程式已達到需求。

回復准提部林
編碼原則正確，阿龍的程式已符合需求，如需其它定義，也能自行修改加入新的編碼原則

資料處理也不是想要一步登天，能大大減少反覆的動作，縮短時間就很棒了，覺得有學到東西

qaqa3296

回復 12# ikboy

感謝ikboy回復

例
6219-1未將6219列出
8011則列出錯誤的A8011

沒什麼大錯誤，只因編碼原則複雜，程式效果可以接受

研究程式中

阿龍程式已達到需求感謝幫忙。

軒云熊

回復 23# qaqa3296
我用正常ㄚ 只是這速度比較慢 沒有像大大們是在記憶體裡面執行的快  還是 這不是你要的?  


javascript:;


javascript:;

javascript:;

javascript:;

javascript:;

准提部林

測試資料太少, 無法多做驗證:
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


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

qaqa3296

回復 25# 准提部林

程式執行過後，目標規格內必須嚴格遵照編碼原則，只要有不符合就會列出大量不符合編碼原則的資料? 太嚴苛了!?

附上測試檔案

回復軒云熊

提供的模擬檔只用於測試尋找。
實際規格內有大量的資訊與項目(沒有規律的型號文字說明等等...把規格當備註打!?)

利用編碼原則從中提取我要的訊息項目。所以我也不知哪裡出錯?

准提部林

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

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

qaqa3296

回復 27# 准提部林

程式列出的資料非常完整，感謝准提部林提供另外的寫法供大家學習

軒云熊

回復 26# qaqa3296

我是用鍵字篩選的方式  看起來結果是一樣的  但我不知道是不是你要求的  
不過準大已經達到你的目的  也給了我學習的機會
  


javascript:;

qaqa3296

回復 29# 軒云熊

1.看你列出的資料你該不會...

目標品名打錯字就會列出資料缺少。庫存內品名有重複就會多列資料? 這...

上面有補充說明：不要以品名為基準查詢，重複與多於資料太多沒有參考價值