[已解决]数据源格式不一样问题

fangniuji

大家帮忙一下这个问题，宏执行A列数据源可以执行，执行G列数据源不行，帮我改改，这两种数据源格式都可执行，谢谢。
Sub KD()
   
  Dim Ar, Arr, i&
    Set R = CreateObject("vbscript.regexp")
    Dim An(1 To 99) As Long, K&, At(), Cel As Range
    Const CN As Double = 25.4
    Set Cel = Range("A:a").Find("%")
    Range("b2:d" & Rows.Count).ClearContents
    If Not Cel Is Nothing Then
        Ar = Range("A2:A" & Cel.Row - 1).Value
        Arr = Range(Cel.Offset(1), Cel.End(4)).Value
        ReDim At(1 To UBound(Ar), 1 To 3)
        With R
            .Global = True
            .Pattern = ".*X.*Y.*"
            For i = 1 To UBound(Arr)
                If Left(Arr(i, 1), 1) = "T" Then
                    K = CByte(Mid(Arr(i, 1), 2))
                Else
                    If .test(Arr(i, 1)) Then
                        An(K) = An(K) + 1
                    End If
                End If
            Next i
            .Pattern = "(T(\d{2}))C(\.\d+)$"
            For i = 1 To UBound(Ar)
                If .test(Ar(i, 1)) Then
                    Arr = Split(.Replace(Ar(i, 1), "$1 $3 $2"))
                    At(i, 1) = Arr(0)
                    At(i, 2) = Arr(1) * CN
                    At(i, 3) = An(CByte(Arr(2)))
                End If
            Next i
        End With
        [b2].Resize(UBound(At), 3) = At
        Set R = Nothing
        MsgBox "处理完毕，请验证。"
    End If
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-16 12:21

其实2段数据也可以共用这一段代码，不过得加个判断就行了。

跳转到最佳答案楼层

hwc2ycy

用的正则，不太熟，但我想，估计要通用有点难吧，内容没有太多的相似。

hwc2ycy

A列是2段，G列是4段，这上计算规则就不适用了。

fangniuji

hwc2ycy 发表于 2012-12-12 21:30
A列是2段，G列是4段，这上计算规则就不适用了。

那就拜托弄G列的宏，谢谢！！！

hwc2ycy

我不知道你计算%上面T开头的什么规律。

fangniuji

hwc2ycy 发表于 2012-12-12 21:39
我不知道你计算%上面T开头的什么规律。

编号取G列%以上有含C字母之前 孔径取C后S之前乘25.4 孔数取%以下如T1到T2含有XY坐标行数多少就是T1孔数，T1下面不一定接T2

fangniuji

hwc2ycy 发表于 2012-12-12 21:39
我不知道你计算%上面T开头的什么规律。

参考一下，这看简单

fangniuji

hwc2ycy 发表于 2012-12-12 21:30
A列是2段，G列是4段，这上计算规则就不适用了。

http://www.excelpx.com/thread-292037-1-1.html 如有时间帮我这个改改，谢谢。

hwc2ycy

1. Sub KD2()
   
2.    
   
3.   Dim Ar, Arr, i&
   
4.     Set R = CreateObject("vbscript.regexp")
   
5.     Dim An(1 To 99) As Long, K&, At(), Cel As Range
   
6.     Const CN As Double = 25.4
   
7.     Set Cel = Range("g:g").Find("%")
   
8.     Range("h2:j" & Rows.Count).ClearContents
   
9.     If Not Cel Is Nothing Then
   
10.         Ar = Range("g2:g" & Cel.Row - 1).Value
    
11.         Arr = Range(Cel.Offset(1), Cel.End(4)).Value
    
12.         ReDim At(1 To UBound(Ar), 1 To 3)
    
13.         With R
    
14.             .Global = True
    
15.             .Pattern = ".*X.*Y.*"
    
16.             For i = 1 To UBound(Arr)
    
17.                 If Left(Arr(i, 1), 1) = "T" Then
    
18.                     K = CByte(Mid(Arr(i, 1), 2))
    
19.                     'Debug.Print Arr(i, 1), i, K
    
20.                 Else
    
21.                     If .test(Arr(i, 1)) Then
    
22.                         'Debug.Print Arr(i, 1), An(K)
    
23.                         An(K) = An(K) + 1
    
24.                     End If
    
25.                 End If
    
26.             Next i
    
27.             
    
28.             .Pattern = "(T(\d{2}))C(\.\d+)S(\d+)\.F(\d+)(\.H(\d+))$"
    
29.             For i = 1 To UBound(Ar)
    
30.                 If .test(Ar(i, 1)) Then
    
31.                     Debug.Print Ar(i, 1)
    
32.                     Dim temp
    
33.                     temp = .Replace(Ar(i, 1), "$1 $3 $2")
    
34.                     Arr = Split(.Replace(Ar(i, 1), "$1 $3 $2"))
    
35.                     At(i, 1) = Arr(0)
    
36.                     At(i, 2) = Arr(1) * CN
    
37.                     At(i, 3) = An(CByte(Arr(2)))
    
38.                 End If
    
39.             Next i
    
40.         End With
    
41.         [h2].Resize(UBound(At), 3) = At
    
42.         Set R = Nothing
    
43.         MsgBox "处理完毕，请验证。"
    
44.     End If
    
45. End Sub

复制代码

hwc2ycy

其实2段数据也可以共用这一段代码，不过得加个判断就行了。