我們可以不要懂VBA，但要會懂得用VBA！每個人都可以創建一個屬于自己的【E幫辦公】。

情景

随着工作的數字化、地理信息化，最近在工作中遇到很多經緯度采取的事。現場采集回來的經緯度格式五花八門，不能直接滿足使用要求，需進一步轉換。主要就是十進制表示和度分秒表示之間的轉換，還有度、分、秒符号的問題，有些不是英文标的需要轉成英文标。為此設計一個經緯度轉換的小程序，添加到【E幫辦公】中，方便使用。不用再打開浏覽器搜索在線經緯度轉換；也不用再用一堆函數，設置一堆中間量來轉換了。

在線經緯度轉換

自編公式經緯度轉換

方案

獲取需轉換單元格的經緯度，利用split（）函數将數據進行切片并組成新數組，判斷數組長度以識别經緯度的類型。最後通過經緯度轉換公式來生成所需的經緯度格式，同時考慮是否将經緯合并在一起表示，用“，”隔開。

---

如果你覺得有用，還希望給個【關注】給個【贊】！

如果你想要自己的小功能，點擊【關注】，在評價區留下小功能的要求！

有需要，可【關注】後【私信】“經緯度格式轉換”獲取模塊。

創建自己的選項卡及将程序添加到選項卡中，參照文章【VBA小程序的添加——創建自己的選項卡】

---

附上代碼供參考

模塊部分

Sub 經緯度格式轉換() Application.DisplayAlerts = False '//關閉系統提示 latLongConversion.Show Application.DisplayAlerts = True '//恢複系統提示 End Sub

窗體部門

Private Sub CommandButton1_Click() On Error Resume Next Dim LatLonRow, LatLonCol, AcRow, AcCol, llArr As Variant, llList As Variant, inRange As Variant, Lat, Lon If OptionButton1.Value = True Then Set llArr = Application.InputBox(prompt, Title:="請選擇需轉換經緯度的區域", Type:=8) '獲取經緯度數據 Set inRange = Application.InputBox(prompt, Title:="請選擇經緯度插入的起始位置（單個單元格）", Type:=8) '獲取經緯度數據 If inRange Is Nothing Then AcRow = ActiveCell.Row '獲取當前單元格所在行 AcCol = ActiveCell.Column '獲取當前單元格所在列 Else AcRow = inRange.Row '獲取當前單元格所在行 AcCol = inRange.Column '獲取當前單元格所在列 End If If llArr Is Nothing Then MsgBox "未選取有效數據，程序退出！" Exit Sub End If For i = 1 To llArr.Count Lat = "" Lon = "" ll = llArr(i).Value ll = Replace(ll, "°", "#")'對經緯度中的字符進行替換 ll = Replace(ll, "′", "#") ll = Replace(ll, "″", "#") ll = Replace(ll, "，", "#") ll = Replace(ll, ",", "#") ll = Replace(ll, "##", "#") ll = Replace(ll, " ", "") llList = Split(ll, "#") Lat = Round(llList(0) llList(1) / 60 llList(2) / 3600, 6) Lon = Round(llList(3) llList(4) / 60 llList(5) / 3600, 6) If UBound(llList) > 3 Then If CheckBox1.Value = True Then Cells(AcRow i - 1, AcCol) = Lat & "," & Lon Else Cells(AcRow i - 1, AcCol) = Lat Cells(AcRow i - 1, AcCol 1) = Lon End If Else Cells(AcRow i - 1, AcCol) = Lat End If Next i 'err_1: MsgBox Err.Description & "，程序退出！" Else Set llArr = Application.InputBox(prompt, Title:="請選擇需轉換經緯度的區域", Type:=8) '獲取經緯度數據 Set inRange = Application.InputBox(prompt, Title:="請選擇經緯度插入的起始位置（單個單元格）", Type:=8) '獲取經緯度數據 If inRange Is Nothing Then AcRow = ActiveCell.Row '獲取當前單元格所在行 AcCol = ActiveCell.Column '獲取當前單元格所在列 Else AcRow = inRange.Row '獲取當前單元格所在行 AcCol = inRange.Column '獲取當前單元格所在列 End If If llArr Is Nothing Then MsgBox "未選取有效數據，程序退出！" Exit Sub End If For i = 1 To llArr.Count latD = "" latF = "" latM = "" LonD = "" LonF = "" LonM = "" ll = llArr(i).Value ll = Replace(ll, "°", "") ll = Replace(ll, "，", "#") ll = Replace(ll, ",", "#") llList = Split(ll, "#") latD = Int(llList(0)) latF = Int((llList(0) - latD) * 60) latM = Round((((llList(0) - latD) * 60) - latF) * 60, 2) LonD = Int(llList(1)) LonF = Int((llList(1) - LonD) * 60) LonM = Round((((llList(1) - LonD) * 60) - LonF) * 60, 2) Lat = latD & "°" & latF & "°" & latM & "°" Lon = LonD & "°" & LonF & "°" & LonM & "°" If UBound(llList) = 1 Then If CheckBox1.Value = True Then If Lat <> "" And Lon <> "" Then Cells(AcRow i - 1, AcCol) = Lat & "," & Lon Else If Lat <> "" Then Cells(AcRow i - 1, AcCol) = Lat Else Cells(AcRow i - 1, AcCol) = Lon End If End If Else If Lat <> "" And Lon <> "" Then Cells(AcRow i - 1, AcCol) = Lat Cells(AcRow i - 1, AcCol 1) = Lon Else If Lat <> "" Then Cells(AcRow i - 1, AcCol) = Lat Else Cells(AcRow i - 1, AcCol 1) = Lon End If End If End If Else If llList(0) <> "" Then Cells(AcRow i - 1, AcCol) = Lat End If End If Next i End If End Sub Private Sub CommandButton2_Click() Unload Me End Sub

,

更多精彩资讯请关注tft每日頭條，我们将持续为您更新最新资讯!

查看全部