Board logo

標題: [發問] 該如何某些條件必須符合，某一條件可模糊比對？ [打印本頁]
作者: tsoo811024    時間: 2020-8-19 14:44     標題: 該如何某些條件必須符合，某一條件可模糊比對？

本帖最後由 tsoo811024 於 2020-8-19 14:45 編輯

小弟碰到一個問題，該如何區、里、路(街)、弄、巷同時符合，門牌號盡量符合地去抓取已知座標值?

例如:烏日區光明里光明路152號，因只有烏日區光明里光明路149號、烏日區光明里光明路153號之已知座標值
能否比對後抓取烏日區光明里光明路153號(最相近之門牌)當作152號之座標值，並標註為模糊比對...

因論壇附件上限１MB，沒辦法上傳，故用google雲端上傳~有勞大神賜教...
https://drive.google.com/file/d/1cUDCHfHE_Pkv9r3bHd2-u6g7Dgc7O_nt/view?usp=sharing
作者: ikboy    時間: 2020-8-22 14:36

感覺蠻複雜:
  1. Sub zz()
  2. Dim a, b, c(), n&, d As Object, re As Object, aa(), xt As Boolean
  3. Dim dd As Object, s$, p, z(1)
  4. Set re = CreateObject("vbscript.regexp")
  5. Set d = CreateObject("scripting.dictionary")
  6. Set dd = CreateObject("scripting.dictionary")
  7. With Sheets(2)
  8.     a = .Range("b2:i" & .[b1048576].End(3).Row)
  9. End With
  10. Application.StatusBar = "Program processing... please wait"
  11. With re
  12.     .Pattern = "(\d+-?\d*)"
  13.     .Global = True
  14.     For i = 1 To UBound(a)
  15.         d(a(i, 1)) = i
  16.         If .test(a(i, 1)) Then
  17.             k = Split(.Replace(a(i, 1), "|$1|"), "|")
  18.             n = Val(k(UBound(k) - 1))
  19.             s = ""
  20.             For j = 0 To UBound(k) - 2 Step 2
  21.                 s = s & k(j)
  22.             Next
  23.             If dd.exists(s) Then
  24.                 p = dd(s)
  25.                 ReDim Preserve p(UBound(p) + 1)
  26.                 p(UBound(p)) = n & "|" & i
  27.                 dd(s) = p
  28.             Else
  29.                 dd(s) = Array(n & "|" & i)
  30.             End If
  31.         End If
  32.     Next
  33. End With
  34. For Each k In dd.keys
  35.     p = dd(k)
  36.     ReDim b(UBound(p), 1)
  37.     For j = 0 To UBound(p)
  38.         t = Split(p(j), "|")
  39.         b(j, 0) = Val(t(0))
  40.         b(j, 1) = Val(t(1))
  41.     Next
  42.     For i = 0 To UBound(b) - 1
  43.         t = b(i, 0)
  44.         For j = i + 1 To UBound(b)
  45.             If b(j, 0) < t Then t = b(j, 0): jj = j: xt = True
  46.         Next
  47.         If xt Then
  48.             xt = False
  49.             For j = 0 To 1
  50.                 z(j) = b(i, j)
  51.                 b(i, j) = b(jj, j)
  52.                 b(jj, j) = z(j)
  53.             Next
  54.         End If
  55.     Next
  56.     dd(k) = b
  57. Next
  58. With Sheets(1)
  59.     b = .Range("b2:b" & .[b1048576].End(3).Row)
  60.     .Cells(2, "h").Resize(UBound(b), 3).Clear
  61.     ReDim c(1 To UBound(b), 1 To 3)
  62.     For i = 1 To UBound(b)
  63.         Application.StatusBar = "Finised " & i & " of " & UBound(b)
  64.             n = d(b(i, 1))
  65.             If n Then
  66.                 c(i, 1) = a(n, 7): c(i, 2) = a(n, 8)
  67.             Else
  68.                 c(i, 3) = "模糊比對"
  69.                 GoSub FC
  70.                 If dd.exists(s) Then
  71.                     p = dd(s)
  72.                     If n Then
  73.                         If UBound(p) Then
  74.                             If n < p(0, 0) Then n = p(0, 0)
  75.                             n = Application.VLookup(n, dd(s), 2, 1)
  76.                         Else
  77.                             n = dd(s)(0, 1)
  78.                         End If
  79.                         c(i, 1) = a(n, 7): c(i, 2) = a(n, 8)
  80.                     End If
  81.                 End If
  82.             End If
  83.         Next
  84.     Cells(2, "H").Resize(i - 1, 3) = c
  85. End With
  86. Debug.Print dd.Count
  87. Application.StatusBar = False
  88. End
  89. FC:
  90. With re
  91.         If .test(b(i, 1)) Then
  92.             k = Split(.Replace(b(i, 1), "|$1|"), "|")
  93.             n = Val(k(UBound(k) - 1))
  94.             s = ""
  95.             For j = 0 To UBound(k) - 2 Step 2
  96.                 s = s & k(j)
  97.             Next
  98.         End If
  99. End With
  100. Return
  101. End Sub
複製代碼




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