|
- Sub 基本资料()
- Dim Ar, arr, i&
- Range("f2:h" & Rows.Count).ClearContents
- 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("e:e").Find("%")
- ' Range("b2:d" & Rows.Count).ClearContents
- If Not Cel Is Nothing Then
- Ar = Range("e2:e" & 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
- [f2].Resize(UBound(At), 3) = At
- Set R = Nothing
- MsgBox "处理完毕,请验证。"
- End If
- End Sub
复制代码
Ar = Range("e2:e" & Cel.Row - 1).Value
改成Ar = Range("e2:f" & Cel.Row - 1).Value
|
|