[已解决]这样的查询问题编程

marcus84

       这是实际工作的问题，本人想通过VBA来解决，编程难度应该不是很大，但本人VBA编程能力有限，想求助各位大神帮忙。详细问题可见附件，可将已编程好的附件上传至下方或发送至本人邮箱，不胜感谢！

最佳答案

月排行榜 / 总排行榜

xdragon

2014-9-23 23:05

1. Sub test()
   
2.    Dim conn As Object, i%, sr$(1 To 4), sql$, rngarea$
   
3.    Set conn = CreateObject("adodb.connection")
   
4.    conn.Open "dsn=excel files;dbq=" & ThisWorkbook.FullName
   
5.    rngarea = Range("A2:M" & Cells(Rows.Count, 1).End(xlUp).Row).Address(0, 0)
   
6.    sr(1) = [r1]
   
7.    sr(2) = [t1]
   
8.    sr(3) = [w1]
   
9.    sr(4) = [z1]
   
10.    If Len(sr(1)) Then sql = sql & " and 年份>='" & sr(1) & "'"
    
11.    If Len(sr(2)) Then sql = sql & " and 年份<='" & sr(2) & "'"
    
12.    If Len(sr(3)) Then sql = sql & " and 行业='" & sr(3) & "'"
    
13.    If Len(sr(4)) Then sql = sql & " and 应用类型 like '%" & sr(4) & "%'"
    
14.    sql = IIf(Len(Mid(sql, 5)), " where" & Mid(sql, 5), "")
    
15.    If Cells(Rows.Count, "P").End(xlUp).Row > 2 Then Range("P3:AB" & Cells(Rows.Count, "P").End(xlUp).Row).Clear
    
16.    Range("P3").CopyFromRecordset conn.Execute("select * from [源文件$" & rngarea & "]" & sql)
    
17.    Range("P3:AB" & Cells(Rows.Count, "P").End(xlUp).Row).Borders.LineStyle = 1
    
18. End Sub

复制代码

跳转到最佳答案楼层

这儿有肥猫

下次求助宏的话，起码上传个xlsm的附件吧

xdragon

1. Sub test()
   
2.    Dim conn As Object, i%, sr$(1 To 4), sql$, rngarea$
   
3.    Set conn = CreateObject("adodb.connection")
   
4.    conn.Open "dsn=excel files;dbq=" & ThisWorkbook.FullName
   
5.    rngarea = Range("A2:M" & Cells(Rows.Count, 1).End(xlUp).Row).Address(0, 0)
   
6.    sr(1) = [r1]
   
7.    sr(2) = [t1]
   
8.    sr(3) = [w1]
   
9.    sr(4) = [z1]
   
10.    If Len(sr(1)) Then sql = sql & " and 年份>='" & sr(1) & "'"
    
11.    If Len(sr(2)) Then sql = sql & " and 年份<='" & sr(2) & "'"
    
12.    If Len(sr(3)) Then sql = sql & " and 行业='" & sr(3) & "'"
    
13.    If Len(sr(4)) Then sql = sql & " and 应用类型 like '%" & sr(4) & "%'"
    
14.    sql = IIf(Len(Mid(sql, 5)), " where" & Mid(sql, 5), "")
    
15.    If Cells(Rows.Count, "P").End(xlUp).Row > 2 Then Range("P3:AB" & Cells(Rows.Count, "P").End(xlUp).Row).Clear
    
16.    Range("P3").CopyFromRecordset conn.Execute("select * from [源文件$" & rngarea & "]" & sql)
    
17.    Range("P3:AB" & Cells(Rows.Count, "P").End(xlUp).Row).Borders.LineStyle = 1
    
18. End Sub

复制代码

marcus84

xdragon 发表于 2014-9-23 23:05

你太牛了，已检测，符合我要求

marcus84

这儿有肥猫 发表于 2014-9-23 22:39
下次求助宏的话，起码上传个xlsm的附件吧

运行代码好像出错了

su45

marcus84 发表于 2014-9-23 23:21
你太牛了，已检测，符合我要求

符合要求，就给3楼一个最佳吧！

marcus84

su45 发表于 2014-9-23 23:29
符合要求，就给3楼一个最佳吧！

怎么给啊，我新手不会啊，麻烦指点一下

marcus84

su45 发表于 2014-9-23 23:29
符合要求，就给3楼一个最佳吧！

看到了，会了

这儿有肥猫

marcus84 发表于 2014-9-23 23:21
运行代码好像出错了

未发现出错啊