这个表格转换代码如何实现呢？

rzqf

请各位大佬看看，，，这个表格用VBA如何实现一键转换呢？

fzxba

标高转换.rar (53.4 KB, 下载次数: 20)

2023-6-5 19:55 上传

点击文件名下载附件

gwjkkkkk

没看数据怎么出来的。。。

rzqf

fzxba 发表于 2023-6-5 19:55

谢谢老师的指导，学习啦

fzxba

rzqf 发表于 2023-6-5 22:46
谢谢老师的指导，学习啦

1. Sub test0() '改进一下，仅供测试
   
2.   Dim ar, br, s As String
   
3.   Dim i As Long, j As Integer, k As Integer
   
4.   Dim pos As Integer, posRow As Long, posCol As Integer
   
5.   s = "左桩右"
   
6.   With Sheet1.Range("A1").CurrentRegion
   
7.     br = .Columns(1).Value
   
8.     ar = .Value
   
9.   End With
   
10.   ReDim Preserve br(1 To UBound(br), 1 To UBound(ar, 2) + 2)
    
11.   pos = Int(UBound(ar, 2) / 2) + 2
    
12.   For i = 2 To UBound(ar)
    
13.     posCol = pos
    
14.     k = InStr(s, Left(Trim(ar(i, 1)), 1)) - 2
    
15.     If k <> 0 Then
    
16.       For j = 2 To UBound(ar, 2) Step 2
    
17.         posCol = posCol + k
    
18.         br(posRow + 1, posCol) = ar(i, j) * k
    
19.         br(posRow + 2, posCol) = ar(i, j + 1)
    
20.       Next
    
21.     Else
    
22.       posRow = i
    
23.       br(posRow, UBound(br, 2)) = ar(i, 2)
    
24.       br(posRow + 1, posCol) = 0
    
25.       br(posRow + 2, posCol) = ar(i, 4)
    
26.     End If
    
27.   Next
    
28.   With Sheet2
    
29.     .Cells.ClearContents
    
30.     .Range("A1").Resize(UBound(br), UBound(br, 2)) = br
    
31.   End With
    
32.   Beep
    
33. End Sub

复制代码