VBA
花舞月咏潭
小大不同,日新月异,
展开
-
光学四等红黑尺编数据(点号处理)
Sub 点号递增()Dim i As IntegerDim j As IntegerDim Z As IntegerDim X As IntegerDim M As IntegerDim N As IntegerFor i = 9 To 24 Step 4Z = Cells(i, 18)j = Cells(i, 18) * 4 + 7If i = 9 Then '处理第二行首末站行号Cells(i, 2) = Cells(i, 15)...原创 2022-05-27 10:37:32 · 232 阅读 · 0 评论 -
vba 光学四等水准
得到点原创 2022-05-25 11:08:10 · 98 阅读 · 0 评论 -
CAD2006 ----VBA(Hello World)
Sub Hello()ThisDrawing.Application.Documents.AddDim insPoint(0 To 2) As Double '定义插入点Dim textHeight As Double '定义文本高度Dim textStr As String '定义文本字符Dim textObj As AcadText '定义文本对象insPoint(0) = 2 '设定插入点 X 坐标insPoint(1) = 4 '设定插入点 Y 坐标insPoint(2) = 0 '原创 2022-05-13 14:10:10 · 580 阅读 · 0 评论 -
VBA已知高差编四等水准数据
Sub 高差()Dim I, Z As IntegerZ = Cells(9, 17)Dim G As DoubleG = Cells(9, 18)For I = 9 To (Z * 4 + 1) Step 4Cells(I, 12) = Rnd() * 0.4 - 0.2Cells(I + 2, 9) = Cells(I, 12) + Rnd() * 0.006 - 0.003NextCells(I, 12) = G - (Cells(I - 4, 12) + Cells...原创 2022-05-08 09:34:40 · 338 阅读 · 0 评论 -
GPS原始数据vba行互换、设置单元格时间、检查验测点(+-5公分)
Sub x() Dim a As Variant a = Range("c1:c224").Value Range("c1:c224").Value = Range("d1:d224").Value Range("d1:d224").Value = aEnd Sub原创 2022-05-02 09:24:53 · 265 阅读 · 0 评论 -
DIDI3(数字转为TP,小写转换大写)
Sub DINI3处理()Dim i As IntegerFor i = 2 To 319If IsNumeric(Cells(i, 1)) ThenCells(i, 1) = "TP"ElseCells(i, 1) = Cells(i, 1)End IfNextEnd Sub原创 2022-04-27 13:02:51 · 286 阅读 · 2 评论 -
VBA水准平差
水准原创 2022-03-21 13:41:11 · 355 阅读 · 2 评论 -
VBA处理DINI03水准路线(bf)+中间点
Sub TEST()Dim A As DoubleDim i, R As IntegerDim H As StringRange("g1:g100").Offset(0, 1).InsertRange("h1:h100").Offset(0, 1).InsertRange("i1:i100").Offset(0, 1).InsertFor i = 1 To 500If Cells(i, 13) = "Rb" And Cells(i + 1, 13) = "Rf" ThenA = Cel原创 2022-01-01 13:42:53 · 187 阅读 · 0 评论 -
全站仪角度定向,极坐标解算
Sub 导入全站仪数据() Dim Filename As Variant, myText, S, mArr() As String, narr() As String Dim i, y As Long, j As Long Filename = ThisWorkbook.Path & "\1112X.GT7" '指定文件字符串 j = 1 With Worksheets("sheet1") .Cells.ClearContents...原创 2021-11-20 21:31:29 · 596 阅读 · 0 评论 -
导入控制点
Sub 导入控制点() Dim Filename As Variant, myText, mArr() As String Dim i, y As Long, j As Long Filename = ThisWorkbook.Path & "\kz.txt" '指定文件字符串 For y = 1 To 300 If Cells(y, 6) = "K1" Then j = 1 With Worksheets("...原创 2021-11-17 13:24:47 · 235 阅读 · 0 评论 -
全站仪角度自由定向
Sub 坐标高程计算()Dim I, D, F, M As Integer, W, H, Z, T, J, S, G As DoubleDim PI As DoublePI = 3.14159265258979For I = 1 To 245If Cells(I, 1) = "SD" ThenW = Application.Atan2((Cells(3, 7) - Cells(2, 7)), (Cells(3, 8) - Cells(2, 8)))If W < 0 ThenW = ..原创 2021-11-16 12:39:00 · 842 阅读 · 0 评论 -
VBA批量导入全站仪数据
Sub 批量导入数据() Dim Filename As Variant, myText, mArr() As String, narr() As String Dim i, y As Long, j As Long Filename = ThisWorkbook.Path & "\1025X.GT7" '指定文件字符串 j = 1 With Worksheets("sheet1") .Cells.ClearContents ...原创 2021-11-09 12:23:49 · 125 阅读 · 0 评论 -
VBA全站仪编码处理
Sub 碎部点计算()Dim i As IntegerFor i = 2 To 255If IsNumeric(Cells(i, 4)) ThenCells(i, 6) = ""ElseCells(i, 6) = Cells(i, 4) & Cells(i, 2)End IfIf Cells(i, 1) = "STN" ThenCells(i + 1, 6) = Cells(i + 1, 2) '后视点Cells(i, 6) = Cells(i, 2) '测站...原创 2021-11-03 13:14:56 · 113 阅读 · 0 评论 -
极坐标定向
Sub 碎部点计算()Dim i As IntegerFor i = 2 To 255If Cells(i, 1) = "STN" ThenCells(i, 6) = Cells(i, 2)Cells(i + 1, 6) = Cells(i + 1, 2)Cells(i + 3, 6) = Cells(i + 3, 4) & Cells(i + 3, 2)End IfNextEnd Sub原创 2021-11-01 16:19:07 · 89 阅读 · 0 评论 -
角度定向碎部点计算
Sub 碎部点计算()Dim i As IntegerFor i = 1 To 255Cells(i * 2 + 3, 6) = Cells(i * 2 + 3, 4) & Cells(i * 2 + 3, 2)NextEnd Sub原创 2021-09-04 08:35:45 · 87 阅读 · 0 评论 -
excel vba计算平均数
Sub TEST()Dim i As IntegerRange("d1:d255").Cut Range("b1:b255")Range("e1:e255").Cut Range("d1:d255")For i = 1 To 255cells(6,i*3)="= round(average(range(b"&(i*3-2)&":b"&i*3&")",3)End Sub原创 2021-08-14 16:00:18 · 2358 阅读 · 0 评论 -
excel --vba(批量移动文件)
Sub 移动文件() Dim MyPath1 As String, MyPath2 As String, MyName1 As String, MyName2 As String MyPath1 = "C:\Users\Administrator\Desktop\建设村地籍表\地籍调查表(使用权)\" '指定原始文件所在文件夹 MyPath2 = "C:\Users\Administrator\Desktop\建设村地籍表\1\" '指定文件新文件夹,需要事先创建该文件夹...原创 2021-06-14 10:07:31 · 1893 阅读 · 0 评论 -
Word vba 替换
Sub Test()Dim T As StringDim i As LongFor i = 1 To 300 With Selection.Find .Text = "反对" .Replacement.Text = " " .Forward = True End With With Selection If .Find.Forward Then ...原创 2021-02-28 23:38:15 · 450 阅读 · 1 评论 -
vba左右断面cass格式转苏交科断面格式
Sub DM()Dim i, j, m, n As IntegerFor i = 1 To 1236'左断面数据cass格式转苏交科断面格式If Cells(i, 1) = "BEGIN" Then j = iIf Cells(i + 1, 1) = "0" Then m = i - jFor n = 1 To m - 1If Cells(i + 1, 1) = "0" Then Cells(i, 2 * n + 1) = Abs(Cells(i - n, 1)): Cells(i, 2.原创 2021-02-16 11:00:08 · 156 阅读 · 0 评论 -
vba左断面数据cass格式转苏交科断面格式
ub DM()Dim i, j, m, n As IntegerFor i = 1 To 30'左断面数据cass格式转苏交科断面格式If Cells(i, 1) = "BEGIN" Then j = iIf Cells(i + 1, 1) = "BEGIN" Then m = i - jFor n = 1 To m - 1If Cells(i + 1, 1) = "BEGIN" Then Cells(i, 2 * n + 1) = Abs(Cells(i - n, 1)): Cells.原创 2021-02-16 08:25:34 · 169 阅读 · 0 评论 -
vba右断面cass(南方)格式转成EICAD(苏交科断面格式)
Sub test()Dim i, j, m, n As IntegerFor i = 1 To 23If Cells(i, 1) = "BEGIN" Then j = iIf Cells(i + 1, 1) = "BEGIN" Then m = i - jFor n = 1 To m - 1 If Cells(i - m, 1) = "BEGIN" Then Cells(i - m + 1, 2 * n + 1) = Cells(i - m + n + 1, 1): _ ...原创 2021-02-15 19:54:58 · 368 阅读 · 0 评论 -
vba断面计数
Sub test()Dim i, j, m As IntegerFor i = 1 To 14If Cells(i, 1) = "BEGIN" Then j = iIf Cells(i + 1, 1) = "BEGIN" Then m = i - jNextEnd Sub原创 2021-02-15 10:48:55 · 91 阅读 · 0 评论 -
VBA右断面
Sub test()'右断面cass数据转成EICADDim i, j As LongFor i = 1 To 10 j = 1 If Cells(i, j) <> "BEGIN" Then Cells(2, i * 2 - 1) = Cells(i + 1, j): Cells(2, i * 2) = Cells(i + 1, j + 1) Next End Sub原创 2021-02-14 17:25:20 · 82 阅读 · 0 评论 -
Excel VBA断面数据4
Sub hello()Dim m, n As IntegerFor m = 1 To 1236If Cells(m, 1) = "BEGIN" Then Cells(m, 1).Cut Cells(m, 3)NextEnd Sub原创 2020-12-14 10:14:36 · 109 阅读 · 0 评论 -
Excel VBA断面数据 处理3
Sub myhello()'Range("A1:b1").Cut Range("C1")Dim k As IntegerFor k = 1 To 1236If Cells(k, 1) <= 0.01 Then Cells(k, 1) = 0Next kEnd Sub原创 2020-12-08 22:40:04 · 192 阅读 · 0 评论 -
Excel VBA 断面数据处理2---移动数据剪切不要得
Sub Myhello()Dim k As Integer, m As IntegerFor k = 1 To 1236 'If Cells(k, 1) = "BEGIN" Then Cells(k, 1) = Cells(k, 2): Cells(k, 2) = " "If Cells(k, 1) = "BEGIN" Then Cells(k, 1) = Split((Cells(k, 2)), ":")(0): Cells(k, 2) = " "Next kE...原创 2020-12-06 19:23:43 · 184 阅读 · 0 评论 -
EXCEL VBA----断面数据处理1(里程)
Sub Myhello()Dim k As IntegerFor k = 1 To 1236If Cells(k, 1).Value = "BEGIN" Then Cells(k, 2) = " "NextEnd Sub原创 2020-12-03 22:09:24 · 345 阅读 · 0 评论