如何用VBA复制Excel表中某些行（有初始特征值和结尾特征值）

淡永鑫

如题，最近处理一些数据，有哪位大神可以帮忙看一下
我想要从Excel中扣数据，要把初始特征值“五、各艺术品前十大持有人”，结尾特征值“天津文化艺术品交易所月报”之间的行（行数不固定）复制到另一张表中，还请大神帮忙。

淡永鑫

求大神帮看一下我的代码有什么问题
Sub 数据()
Dim n As Integer, i As Integer, k As Integer, rng As Range
Do Until n > 764
n = n + 1
If Cells(n, 1).Value Like "*艺术品前十大持有人*" And Cells(n + 1, 1).Value Like "*(艺术品原持有人保留及发售代理商认购部分除外)*" Then
      i = 1
      Do Until Cells(n + i, 1).Value Like "*天津文化艺术品交易所月报*"
         Sheet1.Rows(n + i + 1).Copy Sheet5.Rows(i + 1)
         i = i + 1
      Loop
  End If
Loop
End Sub

abc123281

建议上传附件

淡永鑫

今天发现里面是一个死循环，但是现在也没想出办法，附件是我部分数据

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr()
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     arr = .Range("a1:a" & r)
   
7.     For i = 1 To UBound(arr)
   
8.       If arr(i, 1) = "五、各艺术品前十大持有人" Then
   
9.         m = m + 1
   
10.         ReDim Preserve brr(1 To 2, 1 To m)
    
11.         brr(1, m) = i
    
12.         brr(2, m) = i
    
13.       ElseIf arr(i, 1) = "天津文化艺术品交易所月报" Then
    
14.         brr(2, m) = i
    
15.       End If
    
16.     Next
    
17.     For k = 1 To UBound(brr, 2)
    
18.       wjm = CStr(k)
    
19.       On Error Resume Next
    
20.       Set ws = Worksheets(wjm)
    
21.       If Err Then
    
22.         Set ws = Worksheets.Add(Worksheets(Worksheets.Count))
    
23.         ws.Name = wjm
    
24.       End If
    
25.       With Worksheets(wjm)
    
26.         Worksheets("sheet1").Rows(brr(1, k) & ":" & brr(2, k)).Copy .Range("a1")
    
27.       End With
    
28.     Next
    
29.   End With
    
30. End Sub
    

复制代码

chxw68

详见附件。

淡永鑫

多谢各位，这个也可以用了，
Sub 数据()
Dim n As Integer, i As Integer, k As Integer, rng As Range
Do Until n > 19340
n = n + 1
If Cells(n, 1).Value Like "*艺术品前十大持有人*" And Cells(n + 1, 1).Value Like "*(艺术品原持有人保留及发售代理商认购部分除外)*" Then
       i = 1
      Do Until Cells(n + i, 1).Value Like "*天津文化艺术品交易所月报*"
         Sheet1.Rows(n + i + 1).Copy Sheet5.Rows(n + i)
         i = i + 1
      Loop
      n = n + 1
  End If
Loop
End Sub

淡永鑫

chxw68 发表于 2018-9-7 15:16
详见附件。

太谢谢您了，膜拜膜拜