[已解决]查询相同一组数据问题

Baibdu

附件 查询相同一组数据.rar (57.47 KB, 下载次数: 23)

2014-7-26 18:35 上传

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

最佳答案

月排行榜 / 总排行榜

26759761@qq.com

2014-7-26 18:52

1. Sub tt()
   
2. Range("k:m").Clear
   
3. Dim a As Integer, k As Integer, n As Integer
   
4. n = Cells(Rows.Count, 3).End(3).Row
   
5. For a = 1 To n
   
6.   If Cells(a, 3) = [f1] And Cells(a + 1, 3) = [g1] Then
   
7.    k = k + 1
   
8.     Range(Cells(a, 1), Cells(a + 1, 3)).Copy Cells(k * 2 - 1, "k")
   
9.    End If
   
10. Next
    
11. End Sub
    

复制代码

跳转到最佳答案楼层

26759761@qq.com

1. Sub tt()
   
2. Range("k:m").Clear
   
3. Dim a As Integer, k As Integer, n As Integer
   
4. n = Cells(Rows.Count, 3).End(3).Row
   
5. For a = 1 To n
   
6.   If Cells(a, 3) = [f1] And Cells(a + 1, 3) = [g1] Then
   
7.    k = k + 1
   
8.     Range(Cells(a, 1), Cells(a + 1, 3)).Copy Cells(k * 2 - 1, "k")
   
9.    End If
   
10. Next
    
11. End Sub
    

复制代码

云影

1. Sub test()
   
2.     Dim arr, x, ar
   
3.     ar = [f1:g1]
   
4.     arr = Range("a1:c" & [a1].End(4).Row + 1)
   
5.     Range("k:m").ClearContents
   
6.     For x = 1 To UBound(arr) - 1
   
7.         If arr(x, 3) = ar(1, 1) And arr(x + 1, 3) = ar(1, 2) Then
   
8.             k = k + 1
   
9.             For y = 1 To 3
   
10.                 Cells(k, 10 + y) = arr(x, y)
    
11.                 Cells(k + 1, 10 + y) = arr(x + 1, y)
    
12.             Next
    
13.             k = k + 2
    
14.         End If
    
15.     Next
    
16. End Sub

复制代码

Baibdu

26759761@qq.com 发表于 2014-7-26 18:52

老师您好，谢谢您帮助。试了一下，效果很好，就是返回的结果有点差别。即返回的结果，两个为一组，隔一行放。不要连在一起了。不知能否修改一下，谢谢了。

26759761@qq.com

Baibdu 发表于 2014-7-26 19:17
老师您好，谢谢您帮助。试了一下，效果很好，就是返回的结果有点差别。即返回的结果，两个为一组，隔一行 ...

1. Sub tt()
   
2. Range("k:m").Clear
   
3. Dim a As Integer, k As Integer, n As Integer
   
4. n = Cells(Rows.Count, 3).End(3).Row
   
5. For a = 1 To n
   
6.   If Cells(a, 3) = [f1] And Cells(a + 1, 3) = [g1] Then
   
7.    k = k + 1
   
8.     Range(Cells(a, 1), Cells(a + 1, 3)).Copy Cells(k * 3 - 2, "k")
   
9.    End If
   
10. Next
    
11. End Sub

复制代码

su45

今天有不少高手出笼了…………