[已解决]用代码根据要求提取数据的问题

晓敏

附件 根据要求提取数据附件.rar (8.42 KB, 下载次数: 10)

2016-11-8 07:43 上传

点击文件名下载附件 谢谢！

最佳答案

月排行榜 / 总排行榜

爱疯

2016-11-8 09:43

Sub test()
    Dim A, B, i
    A = Sheets(1).Range("a1").CurrentRegion
    B = Application.Index(A, UBound(A), 0)
   
    For i = UBound(A) - 2 To 1 Step -2
        If compare(Application.Index(A, i, 0), B) Then Exit For
    Next i
   
    Sheets(2).Range("a1").Resize(1, UBound(A, 2)) = Application.Index(A, i, 0)
    Sheets(2).Range("a2").Resize(1, UBound(A, 2)) = Application.Index(A, i + 1, 0)
End Sub

Function compare(x, y) As Boolean
    Dim j, s
    ReDim arr(99)    '如果B:G都是0到99之间的整数
    For j = 2 To 7
        arr(x(j)) = arr(x(j)) + 1
        arr(y(j)) = arr(y(j)) + 1
    Next j
   
    For j = 0 To UBound(arr)
        If arr(j) > 1 Then s = s + 1
    Next j
    compare = s > 2
End Function

跳转到最佳答案楼层

爱疯

Sub test()
    Dim A, B, i
    A = Sheets(1).Range("a1").CurrentRegion
    B = Application.Index(A, UBound(A), 0)
   
    For i = UBound(A) - 2 To 1 Step -2
        If compare(Application.Index(A, i, 0), B) Then Exit For
    Next i
   
    Sheets(2).Range("a1").Resize(1, UBound(A, 2)) = Application.Index(A, i, 0)
    Sheets(2).Range("a2").Resize(1, UBound(A, 2)) = Application.Index(A, i + 1, 0)
End Sub

Function compare(x, y) As Boolean
    Dim j, s
    ReDim arr(99)    '如果B:G都是0到99之间的整数
    For j = 2 To 7
        arr(x(j)) = arr(x(j)) + 1
        arr(y(j)) = arr(y(j)) + 1
    Next j
   
    For j = 0 To UBound(arr)
        If arr(j) > 1 Then s = s + 1
    Next j
    compare = s > 2
End Function

望帝春心

1. Sub Greenhand()
   
2.     Dim i&, j&, rng As Range, temrng As Range, rn As Range
   
3.     With Sheets(1)
   
4.     j = .Cells(65536, 1).End(3).Row
   
5.     Set rng = .Range(.Cells(j, 2), .Cells(j, "g"))
   
6.     For i = j - 1 To 1 Step -1
   
7.         Set temrng = .Range(.Cells(i, 2), .Cells(i, "g"))
   
8.         n = 0
   
9.         For Each rn In temrng
   
10.             If Application.WorksheetFunction.CountIf(rng, rn) > 0 Then
    
11.                 n = n + 1
    
12.             End If
    
13.         Next
    
14.             If n > 2 Then
    
15.             .Cells(i, 1).Resize(2, 9).Copy Sheets(2).[a1]
    
16.             Sheets(2).Activate
    
17.             Sheets(2).[a1].Select
    
18.             Exit For
    
19.             End If
    
20.     Next
    
21.     End With
    
22. End Sub

复制代码

望帝春心

参考附件。。。。。。。。。。写这么多还会被隐藏....