[已解决]提取代码

fangniuji

把B列数据源%下，两把刀序坐标提取放C，D列如C,D列，M30不是坐标不提取，谢谢。

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-7-25 17:01

1. Private Sub CommandButton1_Click()
   
2. Dim i&, j%, arr, arr1(1 To 100, 1 To 100), n&, l&, m%
   
3. n = Application.Match("%", Range("b1:b" & Range("b65536").End(3).Row), 0)
   
4. arr = Range("b" & n + 1 & ":b" & Range("b65536").End(3).Row)
   
5. m = 0: l = 1
   
6. For i = 1 To UBound(arr)
   
7.   If Left(arr(i, 1), 1) = "T" Then m = m + 1: l = 1: arr1(l, m) = arr(i, 1)
   
8.   If Left(arr(i, 1), 1) = "X" Then l = l + 1: arr1(l, m) = arr(i, 1)
   
9. Next i
   
10. [c1].Resize(UBound(arr1), UBound(arr1, 2)) = arr1
    
11. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

判断条件是什么？
“%”以下明白
“T”开头的为规格对吧
“X”开头的为坐标
那是不是除了这几个关键字，其他都不考虑，比如你举的例子是“M30”，那会不会有其他字母开头的，是不是也不提取？

fangniuji

大灰狼1976 发表于 2013-7-25 14:50
判断条件是什么？
“%”以下明白
“T”开头的为规格对吧

你真厉害，是的。

fangniuji

大灰狼1976 发表于 2013-7-25 14:50
判断条件是什么？
“%”以下明白
“T”开头的为规格对吧

Private Sub CommandButton1_Click()
Dim Arr, i%, m%, brr(1 To 1000, 1 To 10)
n = Application.Match("%", Range("b1:b" & Range("b65536").End(3).Row), 0)
Arr = Range("b1:b" & Range("b65536").End(3).Row)
For i = 1 To UBound(Arr)
If Left(Arr(i, 1), 1) = "T" And Len(Arr(i, 1)) = 3 Then
m = m + 1: r = 0
End If
If (i > n And Len(Arr(i, 1)) > 3) Or (Left(Arr(i, 1), 1) = "T" And Len(Arr(i, 1)) = 3) Then
r = r + 1
brr(r, m) = Arr(i, 1)
End If
Next
Range("c1").Resize(r, m) = brr
End Sub
我的这个代码报错

大灰狼1976

你把工作表的T9改成T09就可以运行了，不过运行结果数据有缺失
另：B列会出现多个“%”吗？

fangniuji

大灰狼1976 发表于 2013-7-25 16:03
你把工作表的T9改成T09就可以运行了，不过运行结果数据有缺失
另：B列会出现多个“%”吗？

就一个，谢谢！！！！！帮忙一下，谢谢！！！！

大灰狼1976

1. Private Sub CommandButton1_Click()
   
2. Dim i&, j%, arr, arr1(1 To 100, 1 To 100), n&, l&, m%
   
3. n = Application.Match("%", Range("b1:b" & Range("b65536").End(3).Row), 0)
   
4. arr = Range("b" & n + 1 & ":b" & Range("b65536").End(3).Row)
   
5. m = 0: l = 1
   
6. For i = 1 To UBound(arr)
   
7.   If Left(arr(i, 1), 1) = "T" Then m = m + 1: l = 1: arr1(l, m) = arr(i, 1)
   
8.   If Left(arr(i, 1), 1) = "X" Then l = l + 1: arr1(l, m) = arr(i, 1)
   
9. Next i
   
10. [c1].Resize(UBound(arr1), UBound(arr1, 2)) = arr1
    
11. End Sub

复制代码