[已解决]有一定的挑战性：从两个工作薄中有条件的查找并提取数据

wenwen000424

在A列输入关键字：如“工作计划”则在“卷内目录.xls”文件中模糊查找，再根据查找到的行中"arch_num"列对应的编号（如此表I列显示的手工结果）再在"案卷目录.xls”文件中查找，取出"p_arch_no"与"dept_name"列中对应内容填写到此表。可能有多条记录，依次向下填充。高手请不要大意的上吧！谢谢。 求助.rar (124.76 KB, 下载次数: 9)

2014-3-15 11:58 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-15 16:27

1. Sub Macro1()
   
2. Dim arr, brr, crr(1 To 60000, 1 To 2), wb As Workbook, d, d2, mypath$, zf$
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. mypath = ThisWorkbook.Path & ""
   
7. zf = [a3]
   
8. Set wb = GetObject(mypath & "卷内目录.xls")
   
9. arr = wb.Sheets(1).Range("a1").CurrentRegion
   
10. wb.Close 0
    
11. Set wb = GetObject(mypath & "案卷目录.xls")
    
12. brr = wb.Sheets(1).Range("a1").CurrentRegion
    
13. wb.Close 0
    
14. For i = 2 To UBound(brr)
    
15.     d(brr(i, 10)) = i
    
16. Next
    
17. For i = 2 To UBound(arr)
    
18.     If arr(i, 1) Like "*" & zf & "*" Then
    
19.         If Not d2.exists(d(arr(i, 5))) Then
    
20.             d2(d(arr(i, 5))) = ""
    
21.             s = s + 1
    
22.             crr(s, 1) = brr(d(arr(i, 5)), 4)
    
23.             crr(s, 2) = brr(d(arr(i, 5)), 8)
    
24.         End If
    
25.     End If
    
26. Next
    
27. [b3:c65536].ClearContents
    
28. If s > 0 Then Range("b3").Resize(s, 2) = crr
    
29. Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr(1 To 60000, 1 To 2), wb As Workbook, d, mypath$, zf$
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. mypath = ThisWorkbook.Path & ""
   
6. zf = [a3]
   
7. Set wb = GetObject(mypath & "卷内目录.xls")
   
8. arr = wb.Sheets(1).Range("a1").CurrentRegion
   
9. wb.Close 0
   
10. Set wb = GetObject(mypath & "案卷目录.xls")
    
11. brr = wb.Sheets(1).Range("a1").CurrentRegion
    
12. wb.Close 0
    
13. For i = 2 To UBound(brr)
    
14.     d(brr(i, 10)) = i
    
15. Next
    
16. For i = 2 To UBound(arr)
    
17.     If arr(i, 1) Like "*" & zf & "*" Then
    
18.         s = s + 1
    
19.         crr(s, 1) = brr(d(arr(i, 5)), 4)
    
20.         crr(s, 2) = brr(d(arr(i, 5)), 8)
    
21.     End If
    
22. Next
    
23. [b3:c65536].ClearContents
    
24. If s > 0 Then Range("b3").Resize(s, 2) = crr
    
25. Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

dsmch

没有多大挑战性，让小学级别的先试试

wenwen000424

dsmch 发表于 2014-3-15 14:16
没有多大挑战性，让小学级别的先试试

代码很简洁，赞一个，测试了一下，请问如何去除重复的，只保留一个，谢谢！

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr(1 To 60000, 1 To 2), wb As Workbook, d, d2, mypath$, zf$
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. mypath = ThisWorkbook.Path & ""
   
7. zf = [a3]
   
8. Set wb = GetObject(mypath & "卷内目录.xls")
   
9. arr = wb.Sheets(1).Range("a1").CurrentRegion
   
10. wb.Close 0
    
11. Set wb = GetObject(mypath & "案卷目录.xls")
    
12. brr = wb.Sheets(1).Range("a1").CurrentRegion
    
13. wb.Close 0
    
14. For i = 2 To UBound(brr)
    
15.     d(brr(i, 10)) = i
    
16. Next
    
17. For i = 2 To UBound(arr)
    
18.     If arr(i, 1) Like "*" & zf & "*" Then
    
19.         If Not d2.exists(d(arr(i, 5))) Then
    
20.             d2(d(arr(i, 5))) = ""
    
21.             s = s + 1
    
22.             crr(s, 1) = brr(d(arr(i, 5)), 4)
    
23.             crr(s, 2) = brr(d(arr(i, 5)), 8)
    
24.         End If
    
25.     End If
    
26. Next
    
27. [b3:c65536].ClearContents
    
28. If s > 0 Then Range("b3").Resize(s, 2) = crr
    
29. Application.ScreenUpdating = True
    
30. End Sub
    

复制代码