模糊查询

yshcy

1、数据源 这张表里，如果D列的姓名是相同的，则B列的会员卡号也是相同的。要根据  数据源 这张表，在  查询这张表的C2单元里录入D列里的  姓名，查询出 数据源 这张表的相关信息，其中消费金额必须查出累计数据。代码现在有个问题：如果 查询  表里的 C2为空，还是能查出所有的累计金额。If Err.Number <> 0 Or Sheets("查询").[c2] = "" Then MsgBox "未查询到记录"  这句代码不知道如何改进

2、这个代码里的转置太多，不知道能否精简下，谢谢。

3190496160

半百

省掉一次转置及一个数组

魂断蓝桥

Sub test()

Dim cnn, myf$, sql$
myf = ThisWorkbook.FullName
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=YES'; Data Source=" & myf
sql = "select 会员卡号,类别,姓名,SUM(消费金额) from [数据源$a1:e] "
With Sheet2
.[A5:D9999] = ""
    If .[C2] <> "" Then
       sql = sql & " WHERE 姓名='" & .[C2] & "' GROUP BY 会员卡号,类别,姓名"
    Else
        sql = sql & " where 月份 is not null GROUP BY 会员卡号,类别,姓名"
    End If
     .Range("A5").CopyFromRecordset cnn.Execute(sql)
End With
Set cnn = Nothing
End Sub

ykcbf1100

新写一个吧，字典+数组

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.28
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("数据源").Range("a1").CurrentRegion
   
6.     ReDim brr(1 To UBound(arr), 1 To 4)
   
7.     With Sheets("查询")
   
8.         st = .[c2].Value
   
9.         If st = Empty Then
   
10.             MsgBox "查询值为空，请重新输入！"
    
11.             Exit Sub
    
12.         End If
    
13.         For i = 2 To UBound(arr)
    
14.             If arr(i, 4) = st Then
    
15.                 s = arr(i, 4)
    
16.                 If Not d.Exists(s) Then
    
17.                     m = m + 1
    
18.                     d(s) = m
    
19.                     For j = 2 To UBound(arr, 2)
    
20.                         brr(m, j - 1) = arr(i, j)
    
21.                     Next
    
22.                 Else
    
23.                     r = d(s)
    
24.                     brr(r, 4) = brr(r, 4) + arr(i, 5)
    
25.                 End If
    
26.             End If
    
27.         Next
    
28.         .[a5:d10000] = ""
    
29.         .Range("a5").Resize(m, 4) = brr
    
30.         .Range("a5").Resize(m, 4).Borders.LineStyle = 1
    
31.     End With
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    

复制代码