[已解决]批量提取数据,望老师们能看一下

nbxxhzh

批量提取前面的数据到最后的工作表，望老师们能看一下

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-29 15:37

请看附件。

跳转到最佳答案楼层

grf1973

1. Sub 提取()
   
2.     Dim xRng As Range
   
3.     arr = [a1].CurrentRegion
   
4.     ReDim brr(1 To 10000, 1 To 11)
   
5.     For i = 2 To UBound(arr)
   
6.         sfz = arr(i, 2)  '身份证
   
7.         For Each sh In Worksheets
   
8.             Set xRng = sh.[g:g].Find(sfz)
   
9.             If Not xRng Is Nothing Then
   
10.                 crr = sh.[a1].CurrentRegion
    
11.                 hz = sh.Cells(xRng.Row, 1) '户主
    
12.                 For k = 1 To UBound(crr)
    
13.                     If crr(k, 1) = hz Then
    
14.                         n = n + 1
    
15.                         For j = 1 To 11
    
16.                             brr(n, j) = crr(k, j)
    
17.                         Next
    
18.                     End If
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.     Next
    
23.     If n > 0 Then [e2].Resize(n, 11) = brr
    
24. End Sub
    

复制代码

grf1973

请看附件。