麻烦大师修改一下查找工作表数据的路径，谢谢！

无忧鸟

       大师们好，因为工作需要想把sheet1放在F盘符的资料文件夹里，然后在sheet2的B2输入条件查找到F盘资料文件夹sheet1的所有数据，这个查找的路径要怎么修改，谢谢！


指定路径查找求助.zip (18.31 KB, 下载次数: 6)

2019-12-30 15:35 上传

点击文件名下载附件

Sub dsmch()
Dim arr, d, i&, j%
Set d = CreateObject("scripting.dictionary")
Sheet2.Activate
[a5:an2000].Clear
tj = [b2]
arr = Sheet1.UsedRange
For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
        If arr(i, j) Like "*" & tj & "*" Then
            If Not d.exists(i) Then d(i) = "": Exit For
        End If
    Next
Next
If d.Count > 0 Then
    For Each a In d.keys
        n = n + 1
        Sheet1.Cells(a, 1).Resize(1, UBound(arr, 2)).Copy Cells(n + 4, 1)
    Next
End If
End Sub

无忧鸟

恳请大师出手相助，谢过了

无忧鸟

有老师愿意帮忙吗

liulang0808

arr = Sheet1.UsedRange 这部分修改下

with workbooks.open("f:\资料\具体文件名")
arr = .Sheet1.UsedRange
.close false
end with

这样看看是否可行吧

无忧鸟

liulang0808 发表于 2019-12-31 07:44
arr = Sheet1.UsedRange 这部分修改下

with workbooks.open("f:\资料\具体文件名")

    根据您的代码修改后运行出现了“运行时错误438 对象不支持该属性或方法”并且
被查找的工作表也弹了出来，不知道是哪里出了问题

Sub dsmch()
Dim arr, d, i&, j%
Set d = CreateObject("scripting.dictionary")
Sheet2.Activate
[a5:an2000].Clear
tj = [b2]
With Workbooks.Open("f:\资料\资料.xlsx")
arr = .Sheet1.UsedRange
.Close False
End With
For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
        If arr(i, j) Like "*" & tj & "*" Then
            If Not d.exists(i) Then d(i) = "": Exit For
        End If
    Next
Next
If d.Count > 0 Then
    For Each a In d.keys
        n = n + 1
        Sheet1.Cells(a, 1).Resize(1, UBound(arr, 2)).Copy Cells(n + 4, 1)
    Next
End If
End Sub

无忧鸟

liulang0808 发表于 2019-12-31 07:44
arr = Sheet1.UsedRange 这部分修改下

with workbooks.open("f:\资料\具体文件名")

    根据您提供的代码修改运行后出现了（运行时错误438，对象不支持该属性或方法），
并且被查找的工作表也弹了出来，不知道是哪里出了问题？

Sub dsmch()
Dim arr, d, i&, j%
Set d = CreateObject("scripting.dictionary")
Sheet2.Activate
[a5:an2000].Clear
tj = [b2]
With Workbooks.Open("f:\资料\资料.xlsx")
arr = .Sheet1.UsedRange
.Close False
End With
For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
        If arr(i, j) Like "*" & tj & "*" Then
            If Not d.exists(i) Then d(i) = "": Exit For
        End If
    Next
Next
If d.Count > 0 Then
    For Each a In d.keys
        n = n + 1
        Sheet1.Cells(a, 1).Resize(1, UBound(arr, 2)).Copy Cells(n + 4, 1)
    Next
End If
End Sub

liulang0808

无忧鸟 发表于 2019-12-31 11:55
根据您提供的代码修改运行后出现了（运行时错误438，对象不支持该属性或方法），
并且被查找的工作 ...

楼主设置下断点，或者分步执行，看看具体问题在哪里吧

answer6141

1. Sub test()
   
2.     Dim arr
   
3.     Dim rng As Range
   
4.     For Each rng In Sheet1.UsedRange
   
5.         If rng.Value = Sheet2.[b2] Then
   
6.             Sheet1.UsedRange.AutoFilter Field:=rng.Column, Criteria1:=Sheet2.[b2].Value
   
7.             Sheet1.UsedRange.Copy Sheet2.Range("a5")
   
8.             Exit For
   
9.         End If
   
10.     Next
    
11.    
    
12. End Sub

复制代码

换了个方法，没有测试，估计会有错误，但是给你提供一个思路，喜欢记得打赏

无忧鸟

liulang0808 发表于 2019-12-31 13:02
楼主设置下断点，或者分步执行，看看具体问题在哪里吧

从.Close False 开始断点后运行都提示“运行时错误438 对象不支持该属性或方法”

.Close False
End With
For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
        If arr(i, j) Like "*" & tj & "*" Then
            If Not d.exists(i) Then d(i) = "": Exit For
        End If
    Next
Next
If d.Count > 0 Then
    For Each a In d.keys
        n = n + 1
        Sheet1.Cells(a, 1).Resize(1, UBound(arr, 2)).Copy Cells(n + 4, 1)
    Next
End If
End Sub

liulang0808

With Workbooks.Open("f:\资料\资料.xlsx")
arr = .Sheets(1).UsedRange
.Close False
End With