[已解决]求帮忙写段代码提取 lot-no10 其中的数字

hanjia

工作表.rar (6.21 KB, 下载次数: 5)

2015-6-19 22:24 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

qh8600

2015-6-20 09:24

1. Sub demo()
   
2.     Dim ar, br(), i, j, m, x
   
3.     ar = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row)
   
4.     For i = 1 To UBound(ar)
   
5.         m = Split(ar(i, 1), ",")
   
6.         x = Application.Max(x, UBound(m) + 1)
   
7.         ReDim Preserve br(1 To UBound(ar), 1 To x)
   
8.         For j = 1 To UBound(br, 2)
   
9.             br(i, j) = Val(Replace(m(j - 1), "lot-no", ""))
   
10.         Next
    
11.     Next
    
12.     Range("b1").Resize(UBound(br), UBound(br, 2)) = br
    
13. End Sub
    

复制代码

附件楼下

跳转到最佳答案楼层

qh8600

1. Sub demo()
   
2.     Dim ar, br(), i, j, m, x
   
3.     ar = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row)
   
4.     For i = 1 To UBound(ar)
   
5.         m = Split(ar(i, 1), ",")
   
6.         x = Application.Max(x, UBound(m) + 1)
   
7.         ReDim Preserve br(1 To UBound(ar), 1 To x)
   
8.         For j = 1 To UBound(br, 2)
   
9.             br(i, j) = Val(Replace(m(j - 1), "lot-no", ""))
   
10.         Next
    
11.     Next
    
12.     Range("b1").Resize(UBound(br), UBound(br, 2)) = br
    
13. End Sub
    

复制代码

附件楼下

qh8600

工作表.rar (14.83 KB, 下载次数: 4)

2015-6-20 09:25 上传

点击文件名下载附件
楼主试试

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i&, s&
   
3. arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
4. ReDim brr(1 To UBound(arr), 1 To 100)
   
5. With CreateObject("vbscript.regexp")
   
6.     .Pattern = "\d+"
   
7.     .Global = True
   
8.     For i = 1 To UBound(arr)
   
9.         s = 0
   
10.         For Each m In .Execute(arr(i, 1))
    
11.             s = s + 1: brr(i, s) = m
    
12.         Next
    
13.         If s > n Then n = s
    
14.     Next
    
15. End With
    
16. Range("b1").Resize(UBound(brr), n) = brr
    
17. End Sub

复制代码

hanjia

dsmch 发表于 2015-6-20 11:28

请教个问题  应该如何把你写的这段合并到  按钮1_Click() 这里面？

Sub 按钮1_Click()
    Dim url, html
    url = "http://www.1396.me/xyft/kaijiang"
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
        Set tr = html.all.tags("tr")
        For i = 0 To tr.Length - 1
            If tr(i).classname = "odd" Or tr(i).classname = "even" Then
            myno = ""
                For j = 0 To tr(i).ChildNodes.Length - 1
                    If tr(i).ChildNodes(j).classname = "nums" Then
                        For Each no In tr(i).ChildNodes(j).ChildNodes
                            If myno = "" Then
                                myno = Replace(no.classname, "pk-no", "")
                            Else
                                myno = myno & "," & Replace(no.classname, "pk-no", "")
                            End If
                        Next
                    End If
                    Cells(i + 1, j + 1) = Replace(tr(i).ChildNodes(j).innertext, vbCrLf, " ")
                Next
                Cells(i + 1, 2) = myno
            End If
        Next
    End With
End Sub
Sub 按钮2_Click()
Range("a2:j65536").ClearContents
End Sub

下面这段就是要合并到  按钮1_Click()
Sub Macro1()
Dim arr, brr, i&, s&
arr = Range("b1:b" & Range("b65536").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 100)
With CreateObject("vbscript.regexp")
    .Pattern = "\d+"
    .Global = True
    For i = 1 To UBound(arr)
        s = 0
        For Each m In .Execute(arr(i, 1))
            s = s + 1: brr(i, s) = m
        Next
        If s > n Then n = s
    Next
End With
Range("l1").Resize(UBound(brr), n) = brr
End Sub