返回列表 上一主題 發帖

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

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

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

模糊比對.rar (11.43 KB)
Jess

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

TOP

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

TOP

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
相同的目的,寫法何止千百,這樣是否較易於理解?

TOP

本帖最後由 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
複製代碼

TOP

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

TOP

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

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

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

TOP

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

TOP

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

喔,不!sheet1才是資料庫。
因為sheet2堛漲r串都比較長,比較亂,所以我在想只要在sheet1堣髀翵鴩鉹仍X個連續字串都符合,就將相關資料抓回sheet2,是我的想法剛好相反嗎?原始檔案看起來像是這樣比對的啊!

這樣說好了,如果sheet2埵酗@筆資料"研發ccab",在sheet1媕雩茯O抓"研發a"吧!
                  如果sheet2埵酗@筆資料"研發ccba",在sheet1媕雩茯O抓"研發b"吧!
純粹個人思考。
Jess

TOP

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

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

TOP

        靜思自在 : 虛空有盡.我願無窮,發願容易行願難。
返回列表 上一主題