经纬度转换器在线转换(手把手教你经纬度的转换)

我们可以不要懂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

给TA打赏
共{{data.count}}人
人已打赏
用户投稿

日进斗金下一句对联(中国传统春联)

2022-3-25 10:39:00

用户投稿

美国有几个航空母舰(亲自带你了解美国的航空母舰)

2022-3-25 22:43:00

⚠️
版权声明:图酷网所提供的文章、教程等内容均为用户发布整理而来,仅供学习参考,。
若您的权利被侵害,请联系站长 QQ: 57143067 或 点击右侧 私信:图酷V 反馈,我们将尽快处理。
0 条回复 A文章作者 M管理员
    暂无讨论,说说你的看法吧