Board logo

標題: [發問] 幫忙解釋這個模糊比對範例檔 [打印本頁]
作者: jesscc    時間: 2011-5-8 18:11     標題: 幫忙解釋這個模糊比對範例檔

可以幫我說明附檔中的程式碼的涵意嗎?很好用，但看不懂?所以不知該怎樣修改成自己需要的。

[attach]6054[/attach]
作者: oobird    時間: 2011-5-8 21:13

建議你提出自己的問題
拿出別人的範例又不適合你用
而且要作者自己才能解釋他的思路
我是看不明白他為什麼要這樣寫
作者: jesscc    時間: 2011-5-8 22:29

不好意思，因為這個範例檔和我目前要做的工作幾乎沒啥差別，所以才會拿來請教各位。
作者: oobird    時間: 2011-5-9 08:38

Sub test()
Dim a, b As Range, i%, j%, arr
a = Sheet1.Range(Sheet1.[a2], Sheet1.[b65536].End(3))
With Sheet2
Set b = .Range(.[a2], .[a65536].End(3))
For i = 1 To UBound(a)
arr = Filter(Application.Transpose(b), a(i, 1))
For j = 0 To UBound(arr)
b.Find(arr(j))(1, 2) = a(i, 2)
Next
Next
End With
End Sub
相同的目的，寫法何止千百，這樣是否較易於理解？
作者: GBKEE    時間: 2011-5-9 09:01

本帖最後由 GBKEE 於 2011-5-9 09:05 編輯

附檔的注解: 但又 不想用 VBA 來使用回圈逐個判斷，避免花費時間過長，
可是 處理資料 是避免不了要用到 迴圈的
附檔的程式 可修改如下
  1. Sub Ex()
  2.     Dim Rng(1 To 2) As Range, R As Range
  3.     With Sheets("Sheet1")
  4.         Set Rng(1) = .Range(.[A2], .[A2].End(xlDown))   '設定比對的欄位範圍
  5.         If Application.CountA(Rng(1)) = 0 Then Exit Sub  '比對的範圍沒資料  離開程式
  6.     End With
  7.     With Sheets("Sheet2")
  8.         Set Rng(2) = .Range(.[A2], .[A2].End(xlDown))   '設定變更的欄位範圍
  9.         If Application.CountA(Rng(2)) = 0 Then Exit Sub '變更的範圍沒資料  離開程式
  10.         Rng(2).Offset(, 100) = Rng(2).Value             'Rng(2)位移100欄位置的值=Rng(2)的值
  11.         Rng(2).Offset(, 1).FormulaR1C1 = "=IF(RC[99]=RC[-1],"""",RC[99])" 'Rng(2)位移1欄位置的寫下公式
  12.     End With
  13.     For Each R In Rng(1)    '依序處裡 比對範圍的儲存格
  14.         If R(1, 2) <> "" Then Rng(2).Offset(, 100).Replace "*" & R & "*", R(1, 2), Lookat:=xlPart
  15.         'Rng(2).Offset(, 100)中 有包含 R的儲存格 更換(Replace)為R(1, 2) [R位移1欄]的字串
  16.     Next
  17.     Rng(2).Offset(, 1).Value = Rng(2).Offset(, 1).Value
  18.     'Rng(2).Offset(, 1)的值=Rng(2).Offset(, 1)的值  'Rng(2).Offset(, 1)原本是公式
  19.     Rng(2).Offset(, 100).Clear  '清除
  20. End Sub
複製代碼
作者: mark15jill    時間: 2011-5-9 10:35

回復 1# jesscc


       剛剛才看到此文章...

稍微看了一下附檔..  在 模組的 t20110308a01 的內容那邊 就已經有說明檔案..
以下是擷取該內容
'＜如何在 EXCEL 中以 "模糊比對" 取得相對應的資料＞
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'■比對來源資料雖有其統一及獨立性質，但要被比對的資料呈現不規則形態，
   '版大 希望用類似 LIKE 的方式比對 B LIKE A，
   '但又 不想用 VBA 來使用回圈逐個判斷，避免花費時間過長，
   '是因為這問題不適用 LIKE 來處理，若依此模式，必先取出一來源值，再迴圈
   '逐一判斷被比對值，亦即如果來源值有 100 個，被比對值有 1,000 個，則須
   '迴圈 100*1,000 次，當然失其效益。
'■還好，有 EXCEL 的〔取代〕功能可使用，能有效地處理這問題，其方法為：
   '將全部〔被比對值〕複製至其〔相對位置〕的輔助欄中，再逐一以〔來源值〕
   '比對，取代為欲取得的〔對應值〕，完成後將輔助欄的結果代入目的區塊中。
   '此方式，僅用到來源值的迴圈 100 次，絕對比公式來得快多了。
'■然而既是〔模糊比對〕加〔取代〕，準確率難保百分百，在字串取代的順序
   '上要以較多字的先取代 , 例如:
   '應先取代〔中華電通〕，再取代〔中華電〕，再取代〔中華〕〔華電〕。
'■比對〔來源值〕不可與要取得的結果〔對應值〕有相同字元，以免雙重取代。
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

不曉得樓主要的是怎樣的效果
光把別人的檔案丟上來然後說要改 也沒說要改什麼結果
說真的 很難讓人幫您 就像上面大大們說的
相同效果(結局) 就有不同方式可以去做解決
就好比 從台北要到屏東  就有好幾種方法可以選擇 (海 陸 空)
如果 選 海  那 又有分 快 慢
如果 選 陸 又有分 縣道 省道 或 高速

以下是稍微更動的程式(含更動的些許說明)
在模組的 T20110308a01 程式下

Dim MyBook As Workbook, ShtA As Worksheet, ShtB As Worksheet, HeadA As Range, HeadB As Range, _
    RowsA As Long, RowsB As Long, bClmn(1 To 4) As Range, Ax(1 To 2), i, j  'bclmn(1 to N)   N= sheet1 的 數量表示 如 取消= 4

Sub 共用參照()
Set MyBook = ThisWorkbook
Set ShtA = MyBook.Sheets("Sheet1")
Set HeadA = ShtA.Range("A1")
With HeadA: RowsA = .Cells(65536 - .Row + 1, 1).End(xlUp).Row - .Row: End With
'-----------------------------------
Set ShtB = MyBook.Sheets("Sheet2")
Set HeadB = ShtB.Range("A1")
With HeadB: RowsB = .Cells(65536 - .Row + 1, 1).End(xlUp).Row - .Row: End With
End Sub

Sub 匯入()
Call 共用參照
If RowsA <= 0 Then MsgBox "※匯入來源無項目資料!　　", 0 + 16: Exit Sub
If RowsB <= 0 Then MsgBox "※匯入目標無項目資料!　　", 0 + 16: Exit Sub
Application.ScreenUpdating = False
'-----------------------------------------
Set bClmn(1) = Range(HeadB.Cells(2, 1), HeadB.Cells(RowsB + 1, 1))
Set bClmn(2) = Range(HeadB.Cells(2, 2), HeadB.Cells(RowsB + 1, 2))
Set bClmn(3) = Range(HeadB.Cells(2, 30), HeadB.Cells(RowsB + 1, 30))
Set bClmn(4) = Range(HeadB.Cells(2, 30), HeadB.Cells(RowsB + 1, 30)) 'set bclmn(N)   N= sheet1 的 數量表示 如 取消= 4 如欲增加該數量表示 則必須新增1列

'-------------------------------------------
bClmn(3).Value = bClmn(1).Value
bClmn(2).FormulaR1C1 = "=IF(RC[28]=RC[-1],"""",RC[28])"
For i = 2 To RowsA + 1
    Ax(1) = HeadA.Cells(i, 1).Value
    Ax(2) = HeadA.Cells(i, 2).Value
    If Ax(1) <> "" And Ax(2) <> "" Then
       bClmn(3).Replace "*" & Ax(1) & "*", Ax(2), Lookat:=xlPart
    End If
Next i
'-----------------------------------------
bClmn(2).Value = bClmn(2).Value
bClmn(3).ClearContents
Beep
End Sub
作者: jesscc    時間: 2011-5-9 20:39

本帖最後由 jesscc 於 2011-5-9 20:40 編輯

非常感謝各位先進的熱心指導，各位大大的功力小弟只能說佩服，但小弟真正的瓶頸，仍未克服，我修改了一下sheet1中的資料，增加了"研發A"、"研發B"並多加了兩個欄位，如此一來sheet2中只要有"研發"字眼的，就都比對不到了，照道理，這並沒有違反資料庫正規化資料唯一性的要求，是VBA沒有這樣的查詢函數嗎?

[attach]6086[/attach]
作者: Hsieh    時間: 2011-5-9 21:45

先從你的需求開始，你是要在sheet2中尋找有sheet1的A欄字串
也就是說Sheet2中有包含Sheet1的字串，然後將代號、類別填到Sheet2
那試問，"研發A"、"研發B"在Sheet2中的資料你如何能找到?
A8內容"(100年3月2日)研發1"
他並未出現"研發A"或"研發B"
所謂模糊比對是說字串中包含關鍵字，還可能出現其他字元
就因為你的關鍵字現在是"研發A"或"研發B"
那麼要在尋找字串中有出現"研發A"或"研發B"
才會被認為比對成功
作者: jesscc    時間: 2011-5-9 22:28

本帖最後由 jesscc 於 2011-5-9 22:39 編輯

喔，不!sheet1才是資料庫。
因為sheet2裏的字串都比較長，比較亂，所以我在想只要在sheet1裏比對到其中幾個連續字串都符合，就將相關資料抓回sheet2，是我的想法剛好相反嗎?原始檔案看起來像是這樣比對的啊!

這樣說好了，如果sheet2裏有一筆資料"研發ccab"，在sheet1裏應該是抓"研發a"吧!
                  如果sheet2裏有一筆資料"研發ccba"，在sheet1裏應該是抓"研發b"吧!
純粹個人思考。
作者: Hsieh    時間: 2011-5-9 23:42

本帖最後由 Hsieh 於 2011-5-9 23:47 編輯

"研發ccba"怎會是有連續字串為"研發b"呢?
這樣說吧
你是要在"研發ccba"中找看看是否有"研發a"或"研發b"
那你把"研發ccba"，每3個字切割會得到
"研發c"、"發cc"、"ccb"、"cba"
這裡面會有"研發a"或"研發b"嗎?
作者: jesscc    時間: 2011-5-10 00:46

我的邏輯錯了，我以為程式會去分辨最接近"研發"的字串，"研發ccab"--> a離研發最近 ^^，我實在是太...

只差最後一步了，不過現在整個腦袋已經亂掉了，謝謝 Hsieh 大給我的觀念!
還有 oobird 大大寫的我比較能夠看得懂，剛剛用它試著去改我的工作檔案，可是一直出現錯誤，搞得我頭昏腦漲的，可不可以我把工作檔案傳來，您指點我一下該如何改?
作者: mark15jill    時間: 2011-5-10 08:05

本帖最後由 mark15jill 於 2011-5-10 08:53 編輯

樓主~ 就您附檔的 訊息來看的話
是 以 sheet1 為基礎 在sheet2 的資料內 下去做搜尋沒錯吧
既然是這樣 那 如果你 sheet2內 沒有相關的資訊 就算你在sheet1 增加再多條件 也是沒用的.

而且 如果按照樓主的意思的話
會造成一種情形
如果單一資料 符合兩種搜尋條件 那 要顯示哪個?? 就跟之前某帖一樣...
例如
      sheet1                  sheet2            顯示
A1      大明      1            大明小明           ?
A2     中明      2             中明                   2
A3      小明      3            小明                   3
那 A1   的話 他顯示要哪個?
作者: chin15    時間: 2011-5-10 08:49

很難懂你的邏輯
"研發ccab"--> a離研發最近 ^^
不是c 離研發最近 ?????
許多朋友不願把問題檔案提出來
又無法描述清楚
造成很多的雞同鴨講
浪費大家的時間與站長的空間
作者: jesscc    時間: 2011-5-10 20:25

回 mark15jill 大
確實會有這種情形，不過我會慢慢修正資料庫的資料，這個問題是可以一步步解決的，謝謝你!

我重新上傳了一個檔案，有新增幾欄資料，要同時傳回Sheet2，請 oobird 大幫我看一下，要如何修改好嗎?

[attach]6109[/attach]
作者: Hsieh    時間: 2011-5-10 21:08

回復 14# jesscc
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With Sheet1
  4. For Each a In .Range(.[B5], .[B56636].End(xlUp))
  5.    d(a & "") = Array(a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 4).Value)
  6. Next
  7. End With
  8. With Sheet2
  9. For Each a In .Range(.[D12], .[D56636].End(xlUp))
  10.     For Each ky In d.keys
  11.        If InStr(a, ky) > 0 Then a.Offset(, 4).Resize(, 4) = d(ky): Exit For
  12.     Next
  13. Next
  14. End With
  15. End Sub
複製代碼
作者: jesscc    時間: 2011-5-10 22:34

謝謝 Hsieh 大!剛剛試著去 run 自己的工作檔案，只傳回4欄的資料是ok的，如果我從 Sheet1 抓回的資料改成32欄(公司的資料很龐大)，用一個迴圈去跑陣列，結果就沒辦法正常執行了，是陣列的因素嗎?我記得好像在哪裡看過文章說明，陣列的"欄"是不能用迴圈去跑的。是這樣嗎?
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With Sheet1
  4. For Each a In .Range(.[B5], .[B56636].End(xlUp))
  5.   For i = 1 To 32
  6.    d(a & "") = Array(a.Offset(, i).Value)     ', a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 4).Value)
  7. Next i
  8. Next
  9. End With
  10. With Sheet2
  11. For Each a In .Range(.[D12], .[D56636].End(xlUp))
  12.     For Each ky In d.keys
  13.        If InStr(a, ky) > 0 Then a.Offset(, 12).Resize(, 32) = d(ky): Exit For
  14.     Next
  15. Next
  16. End With
  17. End Sub
複製代碼
作者: Hsieh    時間: 2011-5-10 22:41

這段就是你的資料範圍對嗎?
For i = 1 To 32
  d(a & "") = Array(a.Offset(, i).Value)     ', a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 4).Value)
Next i
這樣單筆資料還是只有4欄
改成
Dim Ar(32)
For i = 0 To 31
  Ar(i) = a.Offset(, i).Value
Next i
d(a & "") =Ar
這樣就有32欄資料
作者: jesscc    時間: 2011-5-10 22:59

Ok了!
可是剛剛仔細檢查了一下，發現比對後傳回來的資料，有很多筆都不是正確的，真是快被這個模糊比對搞瘋了。
作者: Hsieh    時間: 2011-5-10 23:06

回復 18# jesscc

資料不正確有可能是SHEET2的字串中含有2組以上的關鍵字
程式會認定第一個比對到的關鍵字做判斷
或許你要在關鍵字中歸類下功夫
上傳你的關鍵字清單及錯誤的資料看看才能確定出錯的原因
作者: jesscc    時間: 2011-5-10 23:38

因為資料庫太龐大，我整理一些較具代表性的，明天傳上來，讓您看看。真的好感謝你，幫我解決了好多問題!
作者: mark15jill    時間: 2011-5-11 08:10

回復 14# jesscc

除非是用 精準比對 (100%關鍵字去比對)  否則 通常都會有我所說的情形發生
尤其是 數據的東西 更容易
例如 WIN7 的搜尋功能 就存在此問題
搜尋 10 來說  該搜尋範圍(如有 1000筆資料的話)  會將  會將 10 101~110 1000 以前 該搜尋範圍內的檔案(如圖檔) 的格式有 10的也會列出來  (如 100*56 或 1010* 768)
作者: jesscc    時間: 2011-5-11 14:01

本帖最後由 jesscc 於 2011-5-11 21:03 編輯

Hsieh 大:

我已附上工作檔案，資料庫中需要重建檔案的部分，大概都已經有譜了。
目前在資料比對上仍有幾個大問題無法解決:

例如 space,-,&Oslash;,英文字母大小寫不同

只要比對時有出現上面這四種情形，就比對不到了。
之前同事也曾寫過這樣的比對資料程式，大致也是碰到這些瓶頸。

附檔 SPECforMRPtest.xls 的 Sheets("MRP")中有標示紅字的就是比對不到的資料。
作者: Hsieh    時間: 2011-5-11 18:45

space個數不同，大小寫不同，有-跟沒-
599-252  Washer與599-252 Washer差了一個space
110334-1-ZA與110334-1-Z-A差了一個-
40366109240 pIN若不分大小寫怎麼判定是40366109240 PIN還是40366109240  Pin
程式的邏輯就只是把關鍵字是否存在於搜尋字串內
若搜尋字串不包含完整關鍵字，當然比對不到
作者: jesscc    時間: 2011-5-11 21:02

瞭解了，謝謝您的幫忙!也謝謝其他各位先進的幫忙指教!
作者: no8    時間: 2013-10-4 00:25

好棒的應用檔案
感謝分享



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)