[已解决]求助代码：顺藤摸瓜查询目标数据

HongMeig

附件 顺藤摸瓜查询目标.rar (124.71 KB, 下载次数: 19)

2013-1-10 09:10 上传

点击文件名下载附件

谢谢老师们！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-10 10:23

顺藤摸瓜查寻目标附件.rar (20.08 KB, 下载次数: 35)

2013-1-10 10:23 上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

1. Function SearchInWorkbook(ByVal Filename$, ByVal iCol&, ByVal iRow&, ByVal iValue&) As Long
   
2.     Dim wbname$, Path$
   
3.     Dim wb As Workbook
   
4.     Dim rg As Range
   
5.     Path = ThisWorkbook.Path & Application.PathSeparator & "表格" & Application.PathSeparator
   
6.     wbname = Dir(Path & Filename & ".*")
   
7.     If Len(wbname) = 0 Then SearchInWorkbook = 0: Exit Function
   
8.     Set wb = GetObject(Path & wbname)
   
9.     If wb Is Nothing Then SearchInWorkbook = 0: Exit Function
   
10.     With wb.Worksheets("Sheet1")
    
11.         Set rg = .Range(.Cells(1, iCol), .Cells(iRow, iCol)).Find(iValue, , , , , xlPrevious)
    
12.         'Debug.Print rg.Address
    
13.     End With
    
14.     If rg Is Nothing Then
    
15.     SearchInWorkbook = 0
    
16.     Else
    
17.     SearchInWorkbook = rg.Row
    
18.     End If
    
19.     wb.Close False
    
20. End Function

复制代码

工作量有点大，我看看有没有可以改进的地方。

hwc2ycy

千万不要直接在单元格中引用，这样刷新会要死人的，

hwc2ycy

1. Sub 统计()
   
2.     Dim arr, i&
   
3.     i = Cells(Rows.Count, 2).End(xlUp).Row
   
4.     arr = Range("a1:e" & i)
   
5.     Application.ScreenUpdating = False
   
6.     For i = 2 To UBound(arr)
   
7.         If Len(arr(i, 2)) Then
   
8.             arr(i, 5) = SearchInWorkbook(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4))
   
9.         End If
   
10.     Next
    
11.     Range("a1").Resize(UBound(arr), 5) = arr
    
12.     Application.ScreenUpdating = True
    
13.     MsgBox "统计完成"
    
14. End Sub

复制代码

HongMeig

hwc2ycy 发表于 2013-1-10 10:01
工作量有点大，我看看有没有可以改进的地方。

谢谢老师帮助。能不能麻烦老师弄个附件？多谢了。

HongMeig

hwc2ycy 发表于 2013-1-10 10:08

我原来的附件比较乱，复进代码后，会出错。

hwc2ycy

顺藤摸瓜查寻目标附件.rar (20.08 KB, 下载次数: 35)

2013-1-10 10:23 上传

点击文件名下载附件

HongMeig

hwc2ycy 发表于 2013-1-10 10:23

老师您好，程序试用了几天后，发现有读错数据。比如：按要求，是9，却读成39；按要求是8，却读成18，如下图：


39那个位置应读成9。



18那个位置应读成8

有对有错，不知何故。而且总是读成同尾数。

麻烦老师看看好吗？

hwc2ycy

HongMeig 发表于 2013-1-17 20:06
老师您好，程序试用了几天后，发现有读错数据。比如：按要求，是9，却读成39；按要求是8，却读成18，如下 ...

查找的时候没用完全匹配了，当时全是查一位数，我都没有考虑，我改下。

hwc2ycy

1. Function SearchInWorkbook(ByVal Filename$, ByVal iCol&, ByVal iRow&, ByVal iValue&) As Long
   
2.     Dim wbname$, Path$
   
3.     Dim wb As Workbook
   
4.     Dim rg As Range
   
5.     Path = ThisWorkbook.Path & Application.PathSeparator & "表格" & Application.PathSeparator
   
6.     wbname = Dir(Path & Filename & ".*")
   
7.     If Len(wbname) = 0 Then SearchInWorkbook = 0: Exit Function
   
8.     Set wb = GetObject(Path & wbname)
   
9.     If wb Is Nothing Then SearchInWorkbook = 0: Exit Function
   
10.     With wb.Worksheets("Sheet1")
    
11.         Set rg = .Range(.Cells(1, iCol), .Cells(iRow, iCol)).Range.Find(iValue, , xlWhole, , , xlPrevious)
    
12.         'Debug.Print rg.Address
    
13.     End With
    
14.     If rg Is Nothing Then
    
15.     SearchInWorkbook = 0
    
16.     Else
    
17.     SearchInWorkbook = rg.Row
    
18.     End If
    
19.     wb.Close False
    
20. End Function

复制代码