- 帖子
- 406
- 主題
- 8
- 精華
- 0
- 積分
- 453
- 點名
- 0
- 作業系統
- WINDOWS 7
- 軟體版本
- 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2015-2-7
- 最後登錄
- 2021-7-31
|
本帖最後由 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)
|
|
發表於 2020-8-19 03:32
| 
