求助一个批量转换数据格式的代码

zaikp · 发表于 2022-12-3 20:44

各位大神，麻烦帮忙写段vba代码将Sheet1中数据格式转变为Sheet2中数据格式。

Sheet1中数据格式

Sheet2中数据格式

附件中sheet1是原来的数据，sheet2中是我想通过vba实现后的效果，
麻烦哪位大神帮忙编写下，万分感激！！！

liulang0808 · 发表于 2022-12-3 20:54

楼主数据的具体转换规则是什么？

zaikp · 发表于 2022-12-3 21:25

liulang0808 发表于 2022-12-3 20:54
楼主数据的具体转换规则是什么？

对每个坐标除以10000，然后把每组坐标的编号-经度-纬度之间加逗号连接起来，最后把每个区块的所有坐标合并到一个单元格里边,每个坐标后强制换行。

liulang0808 · 发表于 2022-12-4 07:48

Sub 按钮1_Click()
arr = Sheets(1).UsedRange
str1 = ""
str2 = ""
r = 1
arr(1, 3) = "坐标A"
arr(1, 4) = "坐标B"
For j = 2 To UBound(arr)
      If Len(arr(j, 1)) > 0 Then
         If Len(str1) > 0 Then
            arr(r, 3) = str1
            arr(r, 4) = str2
         End If
         r = r + 1
         arr(r, 1) = arr(j, 1)
         arr(r, 2) = arr(j, 2)
         str1 = arr(j, 3) & "," & f_data(arr(j, 4)) & "," & f_data(arr(j, 5))
         str2 = f_data(arr(j, 6)) & "," & f_data(arr(j, 7))
      Else
         str1 = str1 & Chr(10) & arr(j, 3) & "," & f_data(arr(j, 4)) & "," & f_data(arr(j, 5))
         str2 = str2 & Chr(10) & f_data(arr(j, 6)) & "," & f_data(arr(j, 7))
      End If
Next j
arr(r, 3) = str1
arr(r, 4) = str2
Sheets(2).[f1].Resize(r, 4) = arr
End Sub
Function f_data(num)
f_data = Format(num / 10000, "00.0000")
End Function

liulang0808 · 发表于 2022-12-4 07:48

附件内容供参考。。。。。。

准提部林 · 发表于 2022-12-4 11:21

TEST//

Xl0000284.rar (18.17 KB, 下载次数: 5)

zaikp · 发表于 2022-12-4 12:13

问题完美解决谢谢各位大神，问题完美解决！

ahaoge · 发表于 2022-12-4 12:23

A坐标公式:

ahaoge · 发表于 2022-12-4 12:27

假设拐点编号在C列,开始数据行是2,可以用公式完成
A坐标公式:=C2&","&Text(D2&E2,"00.0000,00.0000")

		自动登录	找回密码
密码			免费注册

[求助] 求助一个批量转换数据格式的代码