列出更多的對應資料 - Excel程式區

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2025-10-12

26^# 跳轉到 »

發表於 2020-8-22 17:05 | 只看該作者

回復 25# 准提部林

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

附上測試檔案

回復軒云熊

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

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

列出更多資料V6.zip (25.97 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

25^#

發表於 2020-8-22 15:03 | 只看該作者

本帖最後由准提部林於 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

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2025-6-21

24^#

發表於 2020-8-22 12:18 | 只看該作者

本帖最後由軒云熊於 2020-8-22 12:31 編輯

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

javascript:;

javascript:;

javascript:;

javascript:;

javascript:;

2.png (102 KB)

3png.png (110.93 KB)

4.png (98.25 KB)

1.png (110.9 KB)

列出更多資料.rar (19.82 KB)

TOP

qaqa3296

中學生 Rank: 2

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2025-10-12

23^#

發表於 2020-8-22 12:07 | 只看該作者

回復 12# ikboy

感謝ikboy回復

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

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

研究程式中

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

TOP

qaqa3296

中學生 Rank: 2

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2025-10-12

22^#

發表於 2020-8-22 11:08 | 只看該作者

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

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

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

程式已達到需求。

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

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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

21^#

發表於 2020-8-22 10:09 | 只看該作者

這種文字比對太費周折,
看看是否如下規則, 若有其它, 再補充

拆碼原則.rar (2.37 KB)

可能沒空幫忙寫~~

TOP

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

20^#

發表於 2020-8-22 03:12 | 只看該作者

本帖最後由 n7822123 於 2020-8-22 03:21 編輯

回復 18# qaqa3296

確定就這4種格式摟?  就用你這4種格式進行模糊比對~

如果要添加其他格式在說，我想你看了我的程式也可以自己改了

這裡很多人都可以幫你完成，只要你邏輯敘述夠清楚!

簡單的東西沒必要搞複雜，我的程式邏輯如下

1.依4種格式的規格欄位去查詢庫存，進行模糊比對
2. 規格欄位若有空白字元，則移除空白字元再比對
3.若非此4種格式，則依品號抓資料(單筆)，不模糊比對
4.查詢的資料列到工作表"成果"

程式如下

Sub 模糊查詢()
Dim Rg As Range, 查找範圍 As Range, 此表 As Object
Dim Arr, R&, Key$, MD$, Csft&, K2$, Addr0$, R1&
[成果!A1].CurrentRegion.Offset(1).ClearContents
Arr = Range([D1], [A1].End(4))
Set 此表 = ActiveSheet: Sheets("成果").Activate
R1 = 1: [A1:D1] = Array("品號", "品名", "規格", "數量")
For R = 2 To UBound(Arr)
  MD = Replace(Arr(R, 3), " ", "") '移除空白(不管在哪個位置)
  Key = ""
  If MD Like "####*" Then Key = Left(MD, 4)
  If MD Like "[A-Z]####*" Then Key = Left(MD, 5)
  If MD Like "###-####*" Then Key = Left(MD, 8)
  If MD Like "[A-Z]##-[A-Z]###*" Then Key = Left(MD, 8)
  If Key <> "" Then  '若規格符合上述4種格式，則模糊查詢
Set 查找範圍 = [庫存!C:C]: Csft = -2: K2 = "*"
  Else '若規格不符合上述4種格式，改查品號(僅單筆)
Set 查找範圍 = [庫存!A:A]: Csft = 0: K2 = "": Key = Arr(R, 1)
  End If
  With 查找範圍
Set Rg = .Find(Key & K2, , , xlWhole)
   If Not Rg Is Nothing Then Addr0 = Rg.Address
   Do While Not Rg Is Nothing
      R1 = R1 + 1
      Rg.Resize(, 4).Offset(, Csft).Copy Cells(R1, "A")
      Set Rg = .FindNext(Rg)
      If Rg.Address = Addr0 Then Exit Do
   Loop
  End With
Next R
End Sub

檔案如下

列出更多資料0822.rar (19.34 KB)

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2025-6-21

19^#

發表於 2020-8-22 00:51 | 只看該作者

回復 18# qaqa3296
紅色部分是你的搜尋目標嗎? 如果是你可以用關鍵字篩選比較簡單如果結果不是你要的你可以把 "" & x & "*" 改成你要的方式
Public Sub 模糊篩選()
Range(Cells(2, 1), Cells(2, 4).End(xlDown)).Font.Color = RGB(255, 0, 0)
Application.ScreenUpdating = False
G = True
Sheets(3).Select
Sheets(3).Range(Cells(1, 6), Cells(1, 9).End(xlDown)).Clear
Sheets(2).Select
For K = 2 To Cells(2, 5).End(xlDown).Row
x = Cells(K, 5)
For i = 2 To Cells(2, 3).End(xlDown).Row '依條件篩選

      If Cells(K, 5) = "" Then
         Cells(i, 1).AutoFilter Field:=3, Criteria1:="="
         Range(Cells(2, 1), Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
      Else
         Cells(i, 1).AutoFilter Field:=3, Criteria1:="" & x & "*"
         Range(Cells(2, 1), Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
      End If

      If G = True Then
         Range(Cells(1, 1), Cells(1, 4).End(xlDown)).Copy Sheets(3).Cells(1, 6)
         G = False
      Else
         Range(Cells(2, 1), Cells(2, 4).End(xlDown)).Copy Sheets(3).Cells(1, 6).End(xlDown).Offset(1, 0)
      End If
      Cells(2, 3).AutoFilter
Exit For
Next i
Next K
Sheets(3).Select
Range(Cells(2, 6), Cells(2, 9).End(xlDown)).Font.Color = RGB(0, 0, 0)
Application.ScreenUpdating = True
End Sub

TOP

qaqa3296