1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
Sub 標案土地檢索()
Dim ws As Worksheet ' 工作表變數
Dim rng As Range ' 範圍變數
Dim cell As Range ' 儲存格變數
Dim regex As Object ' 正則表達式對象
Dim matches As Object ' 匹配對象
Dim areaStr As String ' 地區字符串
Dim areaInPing As Double ' 平方公尺數
Dim areaInSquareMeters As Double ' 平方米數
Dim areaInHectares As Double ' 公頃數
Dim totalPrice As Double ' 總價格
Dim pricePerHectare As Double ' 每公頃價格
Dim hectaresText As String ' 公頃文字
Dim pricePerHectareText As String ' 每公頃價格文字
Dim below30Text As String ' 低於30萬文字
Dim lastRow As Long ' 最後一行
Dim filterList() As String ' 篩選列表
Dim filterRange As Range ' 篩選範圍
Dim i As Integer ' 循環計數器
Dim matchFound As Boolean ' 是否找到匹配

' 創建正則表達式對象
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = True
regex.Pattern = "\d+\.\d+平方公尺" ' 匹配“平方公尺”后跟小數的數字

' 確定當前活動工作表
Set ws = ThisWorkbook.ActiveSheet

' 找到D列中的最後一行
lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

' 在E列后插入三個空列，並將其寬度設置為20
Columns("F:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("G:G").ColumnWidth = 20
Columns("H:H").ColumnWidth = 20
Columns("F:F").ColumnWidth = 20

' 為F和G列設置數字格式
Columns("F:F").NumberFormat = "0.00"

' 為G列設置貨幣格式
Columns("G:G").NumberFormat = "0萬元"

' 設置F1、G1和H1的文字
hectaresText = "土地公頃數"
pricePerHectareText = "每公頃多少錢"
below30Text = "每公頃低於30萬"

ws.Range("F1").Value = hectaresText
ws.Range("G1").Value = pricePerHectareText
ws.Range("H1").Value = below30Text

' 遍歷範圍進行土地檢索
For Each cell In ws.Range("E1:E" & lastRow)
If regex.Test(cell.Value) Then
' 提取平方公尺數
Set matches = regex.Execute(cell.Value)
areaStr = matches(0).Value
areaInSquareMeters = Val(Replace(areaStr, "平方公尺", ""))

' 將平方米轉換為公頃，並四舍五入到2位小數
areaInHectares = Round(areaInSquareMeters / 10000, 2)

' 確保如果面積為0，則不進行除法運算
If areaInHectares > 0 Then
' 將公頃數填入F列
cell.Offset(0, 1).Value = areaInHectares

' 從I列獲取總價格
totalPrice = cell.Offset(0, 4).Value

' 計算每公頃價格，並四舍五入到2位小數
pricePerHectare = Round(totalPrice / areaInHectares / 10000, 0)

' 將每公頃價格填入G列
cell.Offset(0, 2).Value = pricePerHectare

' 如果每公頃價格超過30，則在G列突出顯示為淺紅色
If pricePerHectare > 30 Then
cell.Offset(0, 2).Interior.Color = RGB(235, 142, 85) ' 淺紅色
End If

' 如果每公頃價格低於30，則在H列添加“V”符號
If pricePerHectare < 30 Then
cell.Offset(0, 3).Value = "V"
End If
Else
' 如果面積為0，則不做計算並跳過
cell.Offset(0, 1).Value = 0
cell.Offset(0, 2).Value = 0
cell.Offset(0, 3).Value = ""
End If
End If
Next cell

' 指定要篩選的鄉鎮清單
filterList = Split("南澳鄉,大同鄉,烏來區,復興區,關西鎮,尖石鄉,五峰鄉,南庄鄉,獅潭鄉,泰安鄉,和平區,仁愛鄉,魚池鄉,信義鄉,阿里山鄉,那瑪夏區,桃源區,茂林區,三地門鄉,霧台鄉,瑪家鄉,泰武鄉,來義鄉,春日鄉,獅子鄉,牡丹鄉,滿州鄉,達仁鄉,大武鄉,金峰鄉,太麻里鄉,卑南鄉,台東市,蘭嶼鄉,延平鄉,鹿野鄉,關山鎮,東河鄉,池上鄉,成功鎮,海端鄉,長濱鄉,富里鄉,卓溪鄉,玉里鎮,瑞穗鄉,豐濱鄉,光復鄉,鳳林鎮,萬榮鄉,壽豐鄉,吉安鄉,花蓮市,新城鄉,秀林鄉", ",")

' 檢查 D 列中的每個儲存格是否包含指定的鄉鎮
For Each cell In ws.Range("D1:D" & lastRow)
matchFound = False
For i = LBound(filterList) To UBound(filterList)
If InStr(1, cell.Value, filterList(i)) > 0 Then
matchFound = True
Exit For
End If
Next i
If matchFound Then
If filterRange Is Nothing Then
Set filterRange = cell
Else
Set filterRange = Union(filterRange, cell)
End If
End If
Next cell

' 隱藏不匹配的資料行，顯示匹配的資料行，並將其背景色設置為淺綠色
If Not filterRange Is Nothing Then
ws.Rows.Hidden = True ' 隱藏所有行
filterRange.EntireRow.Hidden = False ' 顯示匹配的資料行
ws.Rows(1).Hidden = False ' 顯示首行
filterRange.Interior.Color = RGB(144, 238, 144) ' 設置背景色為淺綠色
ws.Activate
filterRange.Select
Else
MsgBox "未找到符合條件的資料。"
End If

' 開啟A1到N1的篩選功能
ws.Rows("1:1").AutoFilter
' 調整A到G列的欄寬為最適寬度
ws.Columns("A:G").AutoFit
End Sub