情景

随着工作的数字化、地理信息化，最近在工作中遇到很多经纬度采取的事。现场采集回来的经纬度格式五花八门，不能直接满足使用要求，需进一步转换。主要就是十进制表示和度分秒表示之间的转换，还有度、分、秒符号的问题，有些不是英文标的需要转成英文标。为此设计一个经纬度转换的小程序，添加到【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