[已解决]这种情况如何用代码查询？

E见如故

附件 查询D列数据最后一格为A.rar (69.58 KB, 下载次数: 8)

2013-11-23 18:19 上传

点击文件名下载附件
谢谢各位老师。

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-11-23 19:51

我用的2003，所以没有测试，请自己测试一下：

修改查询A.zip (11.61 KB, 下载次数: 2)

2013-11-23 20:19 上传

点击文件名下载附件

1. <div class="blockcode"><blockquote>Sub 查询()
   
2. Dim k&, mypath$, myname$, arr(1 To 1000000, 1 To 1)
   
3. On Error Resume Next
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. mypath = ThisWorkbook.Path & ""
   
7. myname = Dir(mypath & "*.xls")
   
8. Do While myname <> ""
   
9.    If myname <> ThisWorkbook.Name Then
   
10.       With Workbooks.Open(mypath & myname)
    
11.          If .Sheets(1).Range("d65536").End(3).Value = "A" Then
    
12.             k = k + 1
    
13. '            MsgBox Len(myname)
    
14. '           Stop
    
15.             arr(k, 1) = Left(myname, Len(myname) - 4)
    
16.          End If
    
17.          .Close False
    
18.     End With
    
19.     End If
    
20.     myname = Dir
    
21. Loop
    
22. ThisWorkbook.Sheets(1).Range("r1").Resize(k) = arr
    
23. Application.DisplayAlerts = True
    
24. Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

yyyydddd8888

我用的2003，所以没有测试，请自己测试一下：

修改查询A.zip (11.61 KB, 下载次数: 2)

2013-11-23 20:19 上传

点击文件名下载附件

1. <div class="blockcode"><blockquote>Sub 查询()
   
2. Dim k&, mypath$, myname$, arr(1 To 1000000, 1 To 1)
   
3. On Error Resume Next
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. mypath = ThisWorkbook.Path & ""
   
7. myname = Dir(mypath & "*.xls")
   
8. Do While myname <> ""
   
9.    If myname <> ThisWorkbook.Name Then
   
10.       With Workbooks.Open(mypath & myname)
    
11.          If .Sheets(1).Range("d65536").End(3).Value = "A" Then
    
12.             k = k + 1
    
13. '            MsgBox Len(myname)
    
14. '           Stop
    
15.             arr(k, 1) = Left(myname, Len(myname) - 4)
    
16.          End If
    
17.          .Close False
    
18.     End With
    
19.     End If
    
20.     myname = Dir
    
21. Loop
    
22. ThisWorkbook.Sheets(1).Range("r1").Resize(k) = arr
    
23. Application.DisplayAlerts = True
    
24. Application.ScreenUpdating = True
    
25. End Sub
    

复制代码