返回列表 上一主題 發帖

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

本帖最後由 n7822123 於 2020-8-19 03:46 編輯

回復 1# qaqa3296

對於VBA來說,這是 piece of cake

黃色查詢按鈕即可!

程式如下


Sub 模糊查詢()
Dim Rg As Range, Addr0$, R1&
[K:N].ClearContents
With [庫存!C:C]
    Set Rg = .Find([J2] & "*", , , xlWhole)
    If Not Rg Is Nothing Then Addr0 = Rg.Address
    Do While Not Rg Is Nothing
        R1 = R1 + 1
        Rg.Resize(, 4).Offset(, -2).Copy Cells(R1, "K")
        Set Rg = .FindNext(Rg)
        If Rg.Address = Addr0 Then Exit Do
    Loop
End With
End Sub


檔案如下

列出更多資料.rar (17.99 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 9# qaqa3296


   什麼叫做 "格子內有多餘的空白",請講明白一點
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

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

回復 15# qaqa3296


你的"模糊比對" 規則真複雜,6~8碼輪流用?

什麼時候用6碼模糊比對,什麼時候用8碼模糊比對? 有沒有7碼比對?

寫程式講究 "邏輯",你邏輯給的不清不楚,別人只能瞎子摸象!

如准大所說,你應該把"所有" 規格的格式通通列出來,並用顏色區分,要以哪些字元來"模糊比對"

不然以你的"文字敘述" 邏輯,會沒完沒了 ! 下面這句話,說實話,我就真的看不懂!!!

三個字節"-"四個字節做為條件效果,應該可以得到更理想的資料

舉例來說,下面紅色部分是要模糊比對的部分,紅色部分一樣則視為一樣

我隨便列2種,請你把"所有"格式列出,如下參考

A02-A001-E

99-A001-A

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

TOP

本帖最後由 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

本帖最後由 n7822123 於 2020-8-22 23:16 編輯

回復 29# 軒云熊

你可以繼續努力~~

自己辛苦寫出來的程式,會很有成就感!

學習就是不斷嘗試錯誤的過程~

相反,如果只抄別人的程式,就認為自己已經會的那種人....是學不好的

以為自己已經看懂,但就是不能自己寫出來~
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

        靜思自在 : 我們最大的敵人不是別人.可能是自己。
返回列表 上一主題