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

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

11^# 跳轉到 »

發表於 2020-8-21 07:56 | 只看該作者

本帖最後由 jcchiang 於 2020-8-21 07:59 編輯

回復 9# qaqa3296

如果是字串左右的空格,可使用Trim去除
Trim：刪除字串左、右兩端空白
Set Rg = .Find(Left(Trim(a.Offset(, 2)), 8) & "*", , , xlWhole)

TOP

ikboy

中學生 Rank: 2

帖子: 262
主題: 8
精華: 0
積分: 280
點名: 0
作業系統: xp
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2015-8-11
最後登錄: 2025-3-24

2016猴年全勤獎章

12^#

發表於 2020-8-21 10:02 | 只看該作者

回復 9# qaqa3296

Sub zz()
Dim a, d As Object, b, n&
a = Sheets(1).Range("a2:d" & Sheets(1).[a1048576].End(3).Row)
Set d = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
.Pattern = "[-\.\s]+"
.Global = True
For i = 1 To UBound(a)
If Len(a(i, 3)) = 0 Then a(i, 3) = Trim(a(i, 1))
a(i, 3) = Trim(a(i, 3))
k = Split(.Replace(a(i, 3), "|"), "|")
If UBound(k) > 0 Then k = k(0) & "-" & k(1) Else k = a(i, 3)
d(k) = ""
Next
k = Join(d.keys, "|")
.Pattern = k
a = Sheets(2).[a1].CurrentRegion
b = a: n = 1
For i = 2 To UBound(a)
If Len(a(i, 3)) > 0 Then k = a(i, 3) Else k = a(i, 1)
If .TEST(k) Then
n = n + 1
For j = 1 To UBound(a, 2)
b(n, j) = a(i, j)
Next
End If
Next
Workbooks.Add 1
[a1].Resize(n, 4) = b
End With
End Sub

複製代碼

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

13^#

發表於 2020-8-21 10:06 | 只看該作者

回復 9# qaqa3296

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

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

TOP

軒云熊

中學生 Rank: 2

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

14^#

發表於 2020-8-21 18:09 | 只看該作者

本帖最後由軒云熊於 2020-8-21 18:16 編輯

回復 9# qaqa3296
我的寫法比較簡單但是會比較慢你看看是不是你要的如果是文字你就打文字列如煞車用第二個如果是原本的空格你就用第一個

javascript:;

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

TOP

qaqa3296

中學生 Rank: 2

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

15^#

發表於 2020-8-21 20:54 | 只看該作者

本帖最後由 qaqa3296 於 2020-8-21 20:58 編輯

回復n7822123
如jcchiang所說是兩側字串空格

感謝jcchiang補充新的語法

我取得資料時，規格欄被當作備註，打了一堆內容，刪掉那些訊息，則出現兩側字串空格最為常見，原本想說是不是要先用VLOOKUP去更新規格的內容，讓資料不會因人工打得錯誤多了空白等等..

看來也要更新一下思考模式了

回復准提部林
我一開始沒有注意到還有其他規格，如准提部林猜測的一樣

剛剛用LEN函數檢查一下

三個字節"-"四個字節做為條件效果，應該可以得到更理想的資料，再來才是取8碼，8碼以下的將會列出大量多餘資料，所以不需再建立新的規則，就改程式6~8碼輪流用即可

感謝各位大大的幫忙，有學到新的事物，覺得開心

TOP

n7822123

　暱稱: 阿龍

中學生 Rank: 2

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

16^#

發表於 2020-8-21 22:40 | 只看該作者

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

回復 15# qaqa3296

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

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

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

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

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

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

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

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

A02-A001-E

99-A001-A

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

TOP

軒云熊

中學生 Rank: 2

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

17^#

發表於 2020-8-21 23:20 | 只看該作者

如果你只是要避免讓別人打錯那你就用自訂表單比較好吧...

TOP

qaqa3296

中學生 Rank: 2

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

18^#

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

本帖最後由 qaqa3296 於 2020-8-22 00:32 編輯

回復 16# n7822123

說的模模糊糊真的很抱歉

附上圖片

最上面那些很細，可能會列出過多意想不到的資料。

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

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

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

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]