[已解决]分解Vba

fangniuji

帮忙看看，谢谢。

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-5-4 09:31

1. Sub KD()
   
2.     Dim R As New RegExp, Ar, Arr, i&
   
3.     Dim An(1 To 99) As Long, K&, At(), Cel As Range
   
4.     Const CN As Double = 25.4
   
5.     Set Cel = Range("A:a").Find("%")
   
6.     Range("b2:d" & Rows.Count).ClearContents
   
7.     If Not Cel Is Nothing Then
   
8.         Ar = Range("A2:A" & Cel.Row - 1).Value
   
9.         Arr = Range(Cel.Offset(1), Cel.End(4)).Value
   
10.         ReDim At(1 To UBound(Ar), 1 To 3)
    
11.         With R
    
12.             .Global = True
    
13.             .Pattern = ".*X.*Y.*"
    
14.             For i = 1 To UBound(Arr)
    
15.                 If Left(Arr(i, 1), 1) = "T" Then
    
16.                     K = CByte(Mid(Arr(i, 1), 2))
    
17.                 Else
    
18.                     If .Test(Arr(i, 1)) Then
    
19.                         An(K) = An(K) + 1
    
20.                     End If
    
21.                 End If
    
22.             Next i
    
23.             .Pattern = "(T(\d{2}))C(\.\d+)$"
    
24.             For i = 1 To UBound(Ar)
    
25.                 If .Test(Ar(i, 1)) Then
    
26.                     Arr = Split(.Replace(Ar(i, 1), "$1 $3 $2"))
    
27.                     At(i, 1) = Arr(0)
    
28.                     At(i, 2) = Arr(1) * CN
    
29.                     At(i, 3) = An(CByte(Arr(2)))
    
30.                 End If
    
31.             Next i
    
32.         End With
    
33.         [b2].Resize(UBound(At), 3) = At
    
34.         Set R = Nothing
    
35.         MsgBox "处理完毕，请验证。"
    
36.     End If
    
37. End Sub
    

复制代码

Book29.rar (18.57 KB, 下载次数: 7)

2012-5-4 09:31 上传

点击文件名下载附件 是附件这样的效果吗？

跳转到最佳答案楼层

play9091

下面這段代碼可以實現一部分功能……太晚了，想先睡了……或許可以幫到你一點點小忙！

1. Sub Separate()
   
2. For I = 2 To Range("A:A").Find("%").Row - 1
   
3.     Range("B" & I) = Left(Range("A" & I), 3)
   
4.     Range("C" & I) = ("0." & Right(Range("A" & I), 3)) * 25.4
   
5. Next I
   
6. M = 0
   
7. R = 2
   
8. For I = Range("A:A").Find("%").Row To Range("A65536").End(xlUp).Row
   
9.     If Left(Range("A" & I), 1) = "X" Then
   
10.         M = M + 1
    
11.     ElseIf Left(Range("A" & I), 1) = "T" Then
    
12.         Range("D" & R) = M
    
13.         R = R + 1
    
14.         M = 0
    
15.     End If
    
16. Next I
    
17. End Sub
    
18. 
    

复制代码

qhdsun

fangniuji

play9091 发表于 2012-5-4 00:04
下面這段代碼可以實現一部分功能……太晚了，想先睡了……或許可以幫到你一點點小忙！

谢谢，有空时在帮忙，快好了，谢谢！！！

fangniuji

fangniuji 发表于 2012-5-4 08:23
谢谢，有空时在帮忙，快好了，谢谢！！！

就孔数

提取不出来，其他OK啦，谢谢！！！

liuguansky

按你的说明T16的孔数应该为1啊。

无聊的疯子

fangniuji 发表于 2012-5-4 08:33
提取不出来，其他OK啦，谢谢！！！

和楼上一样的同问

为啥T16是2个呢??

fangniuji

liuguansky 发表于 2012-5-4 09:08
按你的说明T16的孔数应该为1啊。

有M的，都不能当坐标提取，谢谢！！是的，谢谢！1

liuguansky

1. Sub KD()
   
2.     Dim R As New RegExp, Ar, Arr, i&
   
3.     Dim An(1 To 99) As Long, K&, At(), Cel As Range
   
4.     Const CN As Double = 25.4
   
5.     Set Cel = Range("A:a").Find("%")
   
6.     Range("b2:d" & Rows.Count).ClearContents
   
7.     If Not Cel Is Nothing Then
   
8.         Ar = Range("A2:A" & Cel.Row - 1).Value
   
9.         Arr = Range(Cel.Offset(1), Cel.End(4)).Value
   
10.         ReDim At(1 To UBound(Ar), 1 To 3)
    
11.         With R
    
12.             .Global = True
    
13.             .Pattern = ".*X.*Y.*"
    
14.             For i = 1 To UBound(Arr)
    
15.                 If Left(Arr(i, 1), 1) = "T" Then
    
16.                     K = CByte(Mid(Arr(i, 1), 2))
    
17.                 Else
    
18.                     If .Test(Arr(i, 1)) Then
    
19.                         An(K) = An(K) + 1
    
20.                     End If
    
21.                 End If
    
22.             Next i
    
23.             .Pattern = "(T(\d{2}))C(\.\d+)$"
    
24.             For i = 1 To UBound(Ar)
    
25.                 If .Test(Ar(i, 1)) Then
    
26.                     Arr = Split(.Replace(Ar(i, 1), "$1 $3 $2"))
    
27.                     At(i, 1) = Arr(0)
    
28.                     At(i, 2) = Arr(1) * CN
    
29.                     At(i, 3) = An(CByte(Arr(2)))
    
30.                 End If
    
31.             Next i
    
32.         End With
    
33.         [b2].Resize(UBound(At), 3) = At
    
34.         Set R = Nothing
    
35.         MsgBox "处理完毕，请验证。"
    
36.     End If
    
37. End Sub
    

复制代码

Book29.rar (18.57 KB, 下载次数: 7)

2012-5-4 09:31 上传

点击文件名下载附件 是附件这样的效果吗？

fangniuji

liuguansky 发表于 2012-5-4 09:31
是附件这样的效果吗？

谢谢谢谢！！！！！！！！！！！！！大家热心帮忙！！！