返回列表 上一主題 發帖

[發問] [已解決]如何地址分類

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2026-7-16 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-2-7 00:54 | 顯示全部帖子
本帖最後由 Hsieh 於 2012-2-7 01:23 編輯

回復 2# owen9399
可製作一個分類表
再以分類表為標準來分類如圖
  1. Sub nn()
  2. Dim Ar(2), Ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("Sheet1")
  5. Ar(0) = Array(.[A1].Value, .[B1].Value, .[C1].Value, .[D1].Value, .[E1].Value)
  6. For Each a In .Range("E2", .[E65536].End(xlUp))
  7. i = IIf(InStr(a, "縣") > 0, 4, 1)
  8.    mystr = Mid(a, i, 3)
  9.    Set B = .Columns("I:K").Find(mystr, lookat:=xlWhole)
  10.    If B Is Nothing Then
  11.       ky = 5
  12.    Else
  13.       ky = .Cells(B.Row, "H").Value
  14.    End If
  15.    If IsEmpty(d(ky)) Then
  16.       Ar(1) = Array(a.Offset(, -4).Value, a.Offset(, -3).Value, a.Offset(, -2).Value, a.Offset(, -1).Value, a.Value)
  17.       d(ky) = Ar
  18.       Else
  19.       Ay = d(ky)
  20.       s = UBound(Ay)
  21.       ReDim Preserve Ay(s + 1)
  22.       Ay(s) = Array(a.Offset(, -4).Value, a.Offset(, -3).Value, a.Offset(, -2).Value, a.Offset(, -1).Value, a.Value)
  23.       d(ky) = Ay
  24.       Erase Ay
  25.     End If
  26. Next
  27. End With
  28. With Sheets("Sheet2")
  29. .[A:F] = ""
  30. r = 1
  31. For Each ky In d.keys
  32.    For i = LBound(d(ky)) To UBound(d(ky))
  33.       .Cells(r, "A").Resize(, 5) = d(ky)(i)
  34.       r = r + 1
  35.    Next
  36. Next
  37. End With
  38. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2026-7-16 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-2-7 15:25 | 顯示全部帖子
本帖最後由 Hsieh 於 2012-2-7 15:29 編輯

回復 4# owen9399
鄉鎮市區做分類不是嗎?
  1. Sub Ex()
  2. Dim Mystr$, Ar(2), Ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("Sheet1")
  5. Ar(0) = Array(.[A1].Value, .[B1].Value, .[C1].Value, .[D1].Value, .[E1].Value)
  6. For Each a In .Range("E2", .[E65536].End(xlUp))
  7.   i = IIf(InStr(a, "縣") > 0, 4, 1) + IIf(Val(a) > 0, Len(CStr(Val(a))), 0) '判斷鄉鎮市區的起始位置
  8.   Mystr = Mid(a, i, 3) '鄉鎮市區
  9.   If IsEmpty(d(Mystr)) Then
  10.      Ar(1) = Array(a.Offset(, -4).Value, a.Offset(, -3).Value, a.Offset(, -2).Value, a.Offset(, -1).Value, a.Value)
  11.      d(Mystr) = Ar '以鄉鎮市區做索引加入內容
  12.      Else
  13.      Ay = d(Mystr)
  14.      s = UBound(Ay)
  15.      ReDim Preserve Ay(s + 1)
  16.      Ay(s) = Array(a.Offset(, -4).Value, a.Offset(, -3).Value, a.Offset(, -2).Value, a.Offset(, -1).Value, a.Value)
  17.      d(Mystr) = Ay '以鄉鎮市區做索引加入內容
  18.   End If
  19. Next
  20. End With
  21. With Sheets("Sheet2")
  22. .PageSetup.PrintArea = "$A:$E" '列印範圍
  23. .ResetAllPageBreaks '重設分頁線
  24. .Cells = ""
  25. r = 1
  26. For Each ky In d.keys
  27.    For i = LBound(d(ky)) To UBound(d(ky))
  28.       .Cells(r, 1).Resize(, 5) = d(ky)(i) '寫入
  29.       r = r + 1
  30.    Next
  31.    .HPageBreaks.Add .Cells(r, "A") '增加分頁
  32. Next
  33. End With
  34. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2026-7-16 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2012-2-8 19:27 | 顯示全部帖子
回復 7# owen9399
樓主的資料並不包含直轄市地址格式
以下程式碼可判斷直轄市
並取得鄉、鎮、市、區的名稱做分類
請各位想想是否有更有效率且適用性更廣的方式
  1. Sub ex()
  2. Dim Ay(2), Ary()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. ar = Array("鄉", "鎮", "市", "區")
  5. With Sheets("Sheet1")
  6. Ay(0) = Array(.[A1].Value, .[B1].Value, .[C1].Value, .[D1].Value, .[E1].Value)
  7. For Each a In .Range("E2", .[E65536].End(xlUp))
  8. For i = 0 To 3
  9.   If k < InStr(a, ar(i)) Then k = InStr(a, ar(i)): b = Mid(a, k, 1)
  10. Next
  11. '取得鄉鎮市區字串
  12. mystr = Mid(a, 1, k):   k = 0
  13. If InStr(mystr, "縣") > 0 Then mystr = Mid(mystr, InStr(mystr, "縣") + 1) '去除縣名
  14. If InStr(mystr, "市") > 0 And InStr(mystr, "區") > 0 Then mystr = Mid(mystr, InStr(mystr, "市") + 1) '去除直轄市
  15. If Val(mystr) > 0 Then mystr = Mid(mystr, Len(CStr(Val(mystr))) + 1) '去除郵遞區號

  17. If IsEmpty(d(mystr)) Then '以未出現過的鄉鎮市區字串作為索引加入內容
  18.    Ay(1) = Array(a.Offset(, -4).Value, a.Offset(, -3).Value, a.Offset(, -2).Value, a.Offset(, -1).Value, a.Value)
  19.    d(mystr) = Ay
  20.    Else '以出現過的鄉鎮市區字串作為索引加入內容
  21.    Ary = d(mystr) '取出陣列
  22.    s = UBound(Ary)
  23.    ReDim Preserve Ary(s + 1) '擴大陣列
  24.    Ary(s) = Array(a.Offset(, -4).Value, a.Offset(, -3).Value, a.Offset(, -2).Value, a.Offset(, -1).Value, a.Value)
  25.    d(mystr) = Ary '寫回鄉鎮市區字串作為索引的內容
  26. End If
  27. Next
  28. End With
  29. With Sheets("Sheet2")
  30. .Cells = ""
  31. r = 1
  32. For Each ky In d.keys '以鄉鎮市區分類的迴圈
  33.   For i = LBound(d(mystr)) To UBound(d(ky))
  34.    .Cells(r, 1).Resize(, 5) = d(ky)(i) '寫入
  35.    r = r + 1
  36.   Next
  37. Next
  38. End With
  39. End Sub
複製代碼
地址分類.rar (14.04 KB)
學海無涯_不恥下問

TOP

        靜思自在 : 犯錯出懺悔心，才能清淨無煩惱。
返回列表 上一主題