高手!高手!高手!请帮忙解决按条件查找数据

369954202

A:J是要查找的对象,O:X是查找到的结果
  L1和M1是输入查找的列,
  L2:L6和M2:M6 是输入要查找的内容
  查找到的内容放到O2:X2下
  
例如 L1是输入B  L2:L6是输,BC-5-8,BC-5-1
     M1是输入I  L2:L6是输,是
   那么B列中有BC-5-8,BC-5-1和I列中有 是 的内空到O2:X2下
   满足两个输入条件查,如果M列不输只按L列一个条件查

uynayna

1 or 2条件查找叫你说的那个复杂。

369954202

uynayna 发表于 2017-9-22 23:08
1 or 2条件查找叫你说的那个复杂。

你能帮帮我下吗,谢谢!

369954202

可以帮帮我吗?谢谢!

martinchen99

菜鸟互助，供参考，测试没问题。

martinchen99

Sub test1()
Application.ScreenUpdating = False
On Error Resume Next
hs1 = Range("l1").End(xlDown).Row
arr = Range("l1").CurrentRegion
brr = Range("a1").CurrentRegion
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Range("o2:x" & UBound(brr)).Clear
For i = 2 To UBound(arr)
   If Len(arr(i, 2)) = 0 Then
      msg1 = arr(i, 1)
     Else
      msg2 = arr(i, 1) & arr(i, 2)
    End If
   dic1(msg1) = ""
   dic2(msg2) = ""
Next i

l1 = Range("l1")
l2 = Range("m1")

ReDim crr(1 To UBound(brr), 1 To 10)
n = 1
For i = 2 To UBound(brr)
  msg3 = Trim(Range(l1 & i) & Range(l2 & i))
  msg4 = Trim(Range(l1 & i))
If dic2.exists(msg3) Then

   For j = 1 To 10

     crr(n, j) = brr(i, j)

   Next j
   n = n + 1
End If

If dic1.exists(msg4) Then

   For j = 1 To 10

     crr(n, j) = brr(i, j)

   Next j
   n = n + 1
End If

Next i

Range("o2").Resize(n - 1, 10) = crr

Set dic1 = Nothing
Set dic2 = Nothing
Application.ScreenUpdating = True


End Sub

lsc900707

1. Sub lqt()
   
2.     arr = [a1].CurrentRegion
   
3.     brr = [l2].CurrentRegion
   
4.     m = UBound(arr): n = UBound(arr, 2)
   
5.     ReDim crr(1 To m, 1 To n)
   
6.     For i = 2 To m
   
7.         For s = 1 To UBound(brr)
   
8.             If (brr(s, 1) = arr(i, 2) And brr(s, 2) = arr(i, 9)) Or (brr(s, 1) = arr(i, 2) And brr(s, 2) = "") Then
   
9.                 k = k + 1
   
10.                 For j = 1 To n
    
11.                     crr(k, j) = arr(i, j)
    
12.                 Next
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     [o1].CurrentRegion.Offset(1) = ""
    
17.     [o2].Resize(k, n) = crr
    
18. End Sub

复制代码

CC例例

1. Sub Inquire_SQL()
   
2.     Dim Conn As Object, Rst As Object
   
3.     Dim strConn$, strSQL$, sMyr$
   
4.     Dim arA, i As Integer
   
5.     Set Conn = CreateObject("ADODB.Connection")
   
6.     Set Rst = CreateObject("ADODB.Recordset")
   
7.     arA = Range("l1").CurrentRegion
   
8.     For i = 2 To UBound(arA)
   
9.         sMyr = IIf(Trim(arA(i, 2)) <> "", "and " & Cells(1, Asc(arA(1, 2)) - 64) & "='" & arA(i, 2) & "'", "")
   
10.         strSQL = strSQL & "or " & Cells(1, Asc(arA(1, 1)) - 64) & "='" & arA(i, 1) & "'" & sMyr
    
11.     Next
    
12.     strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & ThisWorkbook.FullName
    
13.     strSQL = "select * from [sheet1$A1:J32] Where " & Mid(strSQL, 4)
    
14.     Conn.Open strConn
    
15.     Set Rst = Conn.Execute(strSQL)
    
16.     Range("o1").CurrentRegion.Offset(1).ClearContents
    
17.     Range("o2").CopyFromRecordset Rst
    
18.     Rst.Close
    
19.     Conn.Close
    
20.     Set Conn = Nothing
    
21.     Set Rst = Nothing
    
22. End Sub

复制代码

CC例例

附件供参考

369954202

lsc900707 发表于 2017-9-23 07:16

你好,为什么L1输其它列如C查询出现错误?