求助如何修改根据D3单位名称和H3性别提取相关信息。现单条件可提取，两个不可以。谢谢

qinhuan66

求助现有一表可以单个条件提取数年，现需增加为符全两个条件，根据D3单位名称和H3性别来分别提取数据库相关信息Sub 附件4()
With Sheets("数据库")
Sheets(Array("附件4")).Select
   

    [B5:K500].Select
    Selection.ClearContents
     Range("B5").Select
    arr = Sheets("数据库").[a1].CurrentRegion
    W = 4 '
    With Sheets("附件4")
        For i = 2 To UBound(arr) '
'             If arr(i, 5) = Range("$D3") Then
             If arr(i, 5) = Range("$D3") Or arr(i, 3) = Range("$H3") Then
                j = j + 1
                .Cells(W + j, 2) = arr(i, 2)
                .Cells(W + j, 3) = arr(i, 3)
                .Cells(W + j, 4) = arr(i, 5)
                .Cells(W + j, 5) = arr(i, 4)
                .Cells(W + j, 6) = arr(i, 11)
                .Cells(W + j, 7) = arr(i, 8)
            End If
            If j = 10 Then '结束行
                j = 0: W = W + 10 '隔行开始
            End If
        Next
    End With
    End With
    Dim Target As Range
Set Target = Range("$B4")
End Sub

大灰狼1976

@qinhua66

1. Sub test()
   
2. With Sheets(2).[a2].CurrentRegion
   
3.   .AutoFilter Field:=3, Criteria1:=Sheets(1).[h3]
   
4.   .AutoFilter Field:=5, Criteria1:=Sheets(1).[d3]
   
5.   .Range("b2:k" & Sheets(2).[b65536].End(3).Row).Copy
   
6.   Sheets(1).[b5].PasteSpecial Paste:=xlPasteValues
   
7.   .AutoFilter
   
8. End With
   
9. End Sub

复制代码

qinhuan66

大灰狼1976 发表于 2019-6-4 16:59
@qinhua66

好的，收到非常感谢，如果中间有些列数据不需要的怎么办？谢谢

大灰狼1976

那就不要用复制粘贴功能，先转入数组然后再输出到sheet1

qinhuan66

在线等待....老师指点

lsc900707

qinhuan66 发表于 2019-6-4 17:39
在线等待....老师指点

1. Sub 附件4()
   
2.     Dim brr(1 To 9999, 1 To 7)
   
3.     arr = Sheets("数据库").[a1].CurrentRegion
   
4.     For i = 2 To UBound(arr) '
   
5.         If arr(i, 4) = [D3] And arr(i, 3) = [H3] Then
   
6.              m = m + 1
   
7.              brr(m, 1) = m
   
8.              brr(m, 2) = arr(i, 2)
   
9.              brr(m, 3) = arr(i, 3)
   
10.              brr(m, 4) = arr(i, 5)
    
11.              brr(m, 5) = arr(i, 4)
    
12.              brr(m, 6) = arr(i, 11)
    
13.              brr(m, 7) = arr(i, 8)
    
14.         End If
    
15.     Next
    
16.     If m Then
    
17.         Range("a5:h" & Rows.Count).ClearContents
    
18.         [a5].Resize(m, 7) = brr
    
19.     End If
    
20. End Sub

复制代码