[發問] 幫忙解釋這個模糊比對範例檔

jesscc

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

模糊比對.rar (11.43 KB)

下載次數: 25

2011-5-8 18:11

oobird

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

jesscc

不好意思，因為這個範例檔和我目前要做的工作幾乎沒啥差別，所以才會拿來請教各位。

oobird

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

附檔的注解: 但又 不想用 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

回復 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

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

模糊比對修改後.rar (15.47 KB)

下載次數: 15

2011-5-9 20:38

Hsieh

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

jesscc

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

這樣說好了，如果sheet2裏有一筆資料"研發ccab"，在sheet1裏應該是抓"研發a"吧!
                  如果sheet2裏有一筆資料"研發ccba"，在sheet1裏應該是抓"研發b"吧!
純粹個人思考。

Hsieh

"研發ccba"怎會是有連續字串為"研發b"呢?
這樣說吧
你是要在"研發ccba"中找看看是否有"研發a"或"研發b"
那你把"研發ccba"，每3個字切割會得到
"研發c"、"發cc"、"ccb"、"cba"
這裡面會有"研發a"或"研發b"嗎?