[已解决]用VBA如何实现对数据的引用

lzclzch

用VBA如何实现对数据的引用
谢老师们帮忙谢谢

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2011-6-17 16:04

1. 
   
2. Sub yy()
   
3. Dim i&, Myr&, Myc%, Arr, rq1, m&
   
4. Dim rq, Brr, j&, ii&, r1, r%, Arr1()
   
5. Sheet1.Activate
   
6. rq = [h2].Value
   
7. Myc = [iv3].End(xlToLeft).Column
   
8. Brr = Range("h3", Cells(3, Myc))
   
9. Myr = Sheet2.[d65536].End(xlUp).Row
   
10. Arr = Sheet2.Range("d6:i" & Myr)
    
11. Set r1 = Sheet2.[d:d].Find(rq)
    
12. If Not r1 Is Nothing Then
    
13.     For i = 1 To UBound(Brr, 2)
    
14.         m = 0
    
15.         For j = r1.Row - 6 To 6 Step -1
    
16.             If Arr(j, 2) = Brr(1, i) Then
    
17.                 m = m + 1
    
18.                 If m = 1 Then rq1 = Arr(j, 1)
    
19.                 If rq1 - Arr(j, 1) > 4 And rq1 <> "" Then Exit For
    
20.                 r = r + 1
    
21.                 ReDim Preserve Arr1(1 To 6, 1 To r)
    
22.                 For ii = 1 To 6
    
23.                     Arr1(ii, r) = Arr(j, ii)
    
24.                 Next
    
25.             End If
    
26.         Next
    
27.     Next
    
28. End If
    
29. [f8].Resize(6, 200).ClearContents
    
30. [f8].Resize(6, r) = Arr1
    
31. End Sub
    

复制代码

跳转到最佳答案楼层

蓝桥玄霜

1. 
   
2. Sub yy()
   
3. Dim i&, Myr&, Myc%, Arr, rq1, m&
   
4. Dim rq, Brr, j&, ii&, r1, r%, Arr1()
   
5. Sheet1.Activate
   
6. rq = [h2].Value
   
7. Myc = [iv3].End(xlToLeft).Column
   
8. Brr = Range("h3", Cells(3, Myc))
   
9. Myr = Sheet2.[d65536].End(xlUp).Row
   
10. Arr = Sheet2.Range("d6:i" & Myr)
    
11. Set r1 = Sheet2.[d:d].Find(rq)
    
12. If Not r1 Is Nothing Then
    
13.     For i = 1 To UBound(Brr, 2)
    
14.         m = 0
    
15.         For j = r1.Row - 6 To 6 Step -1
    
16.             If Arr(j, 2) = Brr(1, i) Then
    
17.                 m = m + 1
    
18.                 If m = 1 Then rq1 = Arr(j, 1)
    
19.                 If rq1 - Arr(j, 1) > 4 And rq1 <> "" Then Exit For
    
20.                 r = r + 1
    
21.                 ReDim Preserve Arr1(1 To 6, 1 To r)
    
22.                 For ii = 1 To 6
    
23.                     Arr1(ii, r) = Arr(j, ii)
    
24.                 Next
    
25.             End If
    
26.         Next
    
27.     Next
    
28. End If
    
29. [f8].Resize(6, 200).ClearContents
    
30. [f8].Resize(6, r) = Arr1
    
31. End Sub
    

复制代码