[已解决]求助：依据某一条件，提取相关的行

gsmgreen

问题描述如上图所示。左边是原始的数据，右边是想要实现的效果，求高人出手相救

先谢过了！

最佳答案

月排行榜 / 总排行榜

Excel学徒123

2016-8-23 21:39

见下代码，具体见附件

1. 
   
2. Option Explicit
   
3. 
   
4. Sub test()
   
5.     Dim arrSrc, arrRst()
   
6.     Dim irow%, irow_1%, icol%, icnt%, icol_1%
   
7.     arrSrc = Range("a2").CurrentRegion.Value
   
8.     For irow = 3 To UBound(arrSrc)
   
9.         If arrSrc(irow, 4) = 2221 And _
   
10.             Month(arrSrc(irow, 1)) = 6 _
    
11.                 And Year(arrSrc(irow, 1)) = 2016 Then
    
12.                 For irow_1 = 3 To UBound(arrSrc)
    
13.                     If arrSrc(irow, 1) = arrSrc(irow_1, 1) And _
    
14.                             arrSrc(irow, 2) = arrSrc(irow_1, 2) And _
    
15.                                 arrSrc(irow, 3) = arrSrc(irow_1, 3) Then
    
16.                         icnt = icnt + 1
    
17.                         ReDim Preserve arrRst(1 To 5, 1 To icnt)
    
18.                         For icol_1 = 1 To 5
    
19.                             arrRst(icol_1, icnt) = arrSrc(irow_1, icol_1)
    
20.                         Next
    
21.                     End If
    
22.                 Next
    
23.         End If
    
24.     Next
    
25.     Range("i13").Resize(UBound(arrRst, 2), 5) = Application.Transpose(arrRst)
    
26. End Sub

复制代码

跳转到最佳答案楼层

Excel学徒123

没有附件

gsmgreen

请看附件~谢谢！

gsmgreen

Excel学徒123 发表于 2016-8-23 20:47
没有附件

请看附件~

Excel学徒123

见下代码，具体见附件

1. 
   
2. Option Explicit
   
3. 
   
4. Sub test()
   
5.     Dim arrSrc, arrRst()
   
6.     Dim irow%, irow_1%, icol%, icnt%, icol_1%
   
7.     arrSrc = Range("a2").CurrentRegion.Value
   
8.     For irow = 3 To UBound(arrSrc)
   
9.         If arrSrc(irow, 4) = 2221 And _
   
10.             Month(arrSrc(irow, 1)) = 6 _
    
11.                 And Year(arrSrc(irow, 1)) = 2016 Then
    
12.                 For irow_1 = 3 To UBound(arrSrc)
    
13.                     If arrSrc(irow, 1) = arrSrc(irow_1, 1) And _
    
14.                             arrSrc(irow, 2) = arrSrc(irow_1, 2) And _
    
15.                                 arrSrc(irow, 3) = arrSrc(irow_1, 3) Then
    
16.                         icnt = icnt + 1
    
17.                         ReDim Preserve arrRst(1 To 5, 1 To icnt)
    
18.                         For icol_1 = 1 To 5
    
19.                             arrRst(icol_1, icnt) = arrSrc(irow_1, icol_1)
    
20.                         Next
    
21.                     End If
    
22.                 Next
    
23.         End If
    
24.     Next
    
25.     Range("i13").Resize(UBound(arrRst, 2), 5) = Application.Transpose(arrRst)
    
26. End Sub

复制代码

gsmgreen

Excel学徒123 发表于 2016-8-23 21:39
见下代码，具体见附件

感谢老司机带飞！

Excel学徒123

gsmgreen 发表于 2016-8-23 21:57
感谢老司机带飞！

不谢，给个最佳就好了

gsmgreen

Excel学徒123 发表于 2016-8-23 22:07
不谢，给个最佳就好了

如果想在不同的sheet中进行提取（比如以一个叫“sheet1”中的sheet作为），需要如何修改呢？是修改arrSrc = Range("a2").CurrentRegion.Value 这一句中的a2吗？

gsmgreen

gsmgreen 发表于 2016-8-23 22:13
如果想在不同的sheet中进行提取（比如以一个叫“sheet1”中的sheet作为），需要如何修改呢？是修改arrSrc ...

刚才自己尝试出来了~是在a2前面加上sheet1！就行~