[已解决](求助）如何批量提取数据？

yesddd

附件如右 批量提数附件.rar (39.45 KB, 下载次数: 24)

2012-9-8 15:24 上传

点击文件名下载附件   （03版）

谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

cbg2008

2012-9-8 16:18

1. Sub test()
   
2.     Dim arr, brr(), crr(1 To 50, 1 To 3), drr, d1, d2
   
3.     Dim i As Long, j As Long, k As Long, x As Long, y As Long, irow As Long
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     irow = 29    '提定的行
   
7.     For i = 2 To Worksheets.Count
   
8.         With Sheets(i)
   
9.             drr = .Cells(1, 1).Resize(50, 149)
   
10.             arr = .Cells(irow, 1).Resize(1, 149)
    
11.             d1.RemoveAll
    
12.             d2.RemoveAll
    
13.             Erase brr, crr
    
14.             k = 0
    
15.             For x = 51 To 99
    
16.                 d1(arr(1, x)) = ""
    
17.             Next
    
18.             For x = 101 To 149
    
19.                 d2(arr(1, x)) = ""
    
20.             Next
    
21.             For x = 1 To 49
    
22.                 If d1.exists(arr(1, x)) And d2.exists(arr(1, x)) Then
    
23.                     k = k + 1
    
24.                     ReDim Preserve brr(1 To k)
    
25.                     brr(k) = arr(1, x)
    
26.                     If k = 3 Then Exit For
    
27.                 End If
    
28.             Next
    
29.             For x = 1 To 3
    
30.                 For y = x * 50 - 49 To x * 50 - 1
    
31.                     If arr(1, y) = brr(x) Then
    
32.                         For j = 1 To 50
    
33.                             crr(j, x) = drr(j, y)
    
34.                         Next
    
35.                         Exit For
    
36.                     End If
    
37.                 Next
    
38.             Next
    
39.             .Cells(1, 151).Resize(50, 3) = crr
    
40.         End With
    
41.     Next
    
42.     Set d1 = Nothing
    
43.     Set d2 = Nothing
    
44. End Sub

复制代码

跳转到最佳答案楼层

cbg2008

1. Sub test()
   
2.     Dim arr, brr(), crr(1 To 50, 1 To 3), drr, d1, d2
   
3.     Dim i As Long, j As Long, k As Long, x As Long, y As Long, irow As Long
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     irow = 29    '提定的行
   
7.     For i = 2 To Worksheets.Count
   
8.         With Sheets(i)
   
9.             drr = .Cells(1, 1).Resize(50, 149)
   
10.             arr = .Cells(irow, 1).Resize(1, 149)
    
11.             d1.RemoveAll
    
12.             d2.RemoveAll
    
13.             Erase brr, crr
    
14.             k = 0
    
15.             For x = 51 To 99
    
16.                 d1(arr(1, x)) = ""
    
17.             Next
    
18.             For x = 101 To 149
    
19.                 d2(arr(1, x)) = ""
    
20.             Next
    
21.             For x = 1 To 49
    
22.                 If d1.exists(arr(1, x)) And d2.exists(arr(1, x)) Then
    
23.                     k = k + 1
    
24.                     ReDim Preserve brr(1 To k)
    
25.                     brr(k) = arr(1, x)
    
26.                     If k = 3 Then Exit For
    
27.                 End If
    
28.             Next
    
29.             For x = 1 To 3
    
30.                 For y = x * 50 - 49 To x * 50 - 1
    
31.                     If arr(1, y) = brr(x) Then
    
32.                         For j = 1 To 50
    
33.                             crr(j, x) = drr(j, y)
    
34.                         Next
    
35.                         Exit For
    
36.                     End If
    
37.                 Next
    
38.             Next
    
39.             .Cells(1, 151).Resize(50, 3) = crr
    
40.         End With
    
41.     Next
    
42.     Set d1 = Nothing
    
43.     Set d2 = Nothing
    
44. End Sub

复制代码