[已解决]查找某一单元格内容（日期）在另外工作表中的位置并复制对应内容的代码。

一片薄云

请求老师帮助：工作表“查询”a1单元格输入日期完成后  （比如按回车键或选择其他单元格），自动在a2、b2单元格填写表1、表2，并将填写的日期在工作表“表1”、“表2”中搜索，搜索到的单元格下面内容（9行）分别复制到工作表“查询”的a2、b2下面。

同样在其他单元格比如e1、f1输入也要有同样效果。

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-12 09:12

放在查询表时间中，只能实现输入日期后双击日期出结果，Worksheet_Change事件好像做不到！

1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
2.     Dim rng1 As Range, arr(), brr()
   
3.     Set rng = Target
   
4.     With Target
   
5.         If .Row = 1 And Target <> "" Then
   
6.             Set rng1 = Sheet1.Cells.Find(What:=.Value, LookIn:=xlValues, LookAt:=xlWhole)
   
7.             arr = rng1.Offset(1, 0).Resize(9, 1)
   
8.             .Offset(1, 0) = "表1"
   
9.             .Offset(2, 0).Resize(9, 1) = arr
   
10.             Set rng1 = Sheet2.Cells.Find(What:=.Value, LookIn:=xlValues, LookAt:=xlWhole)
    
11.             brr = rng1.Offset(1, 0).Resize(9, 1)
    
12.             .Offset(1, 1) = "表2"
    
13.             .Offset(2, 1).Resize(9, 1) = brr
    
14.         End If
    
15.     End With
    
16.     Cancel = True
    
17. End Sub

复制代码

跳转到最佳答案楼层

baksy

附件

一片薄云

baksy 发表于 2016-6-12 08:29
附件

非常感谢帮助，我想用VBA代码，以便延深使用。

ppp710715

1. Sub ppp()
   
2.   Dim arr, k, i, rng
   
3.   Sheets(3).Range("a2:b100").Clear
   
4.   For i = 1 To 2
   
5.   With Worksheets(i).Range("a1:k500")
   
6.     Set rng = .Find(Sheets(3).Cells(1, 1).Value, LookIn:=xlValues)
   
7.     If Not rng Is Nothing Then
   
8.       arr = rng.Offset(1, 0).Resize(9, 1)
   
9.     End If
   
10. End With
    
11. With Sheets(3)
    
12. 
    
13. .Cells(2, i) = "表" & i
    
14. .Cells(3, i).Resize(9, 1) = arr
    
15. End With
    
16. Set rng = Nothing
    
17. 
    
18. Next
    
19. 
    
20. End Sub
    

复制代码

ppp710715

工作簿1.rar (17.59 KB, 下载次数: 67)

2016-6-12 09:10 上传

点击文件名下载附件

老司机带带我

放在查询表时间中，只能实现输入日期后双击日期出结果，Worksheet_Change事件好像做不到！

1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
2.     Dim rng1 As Range, arr(), brr()
   
3.     Set rng = Target
   
4.     With Target
   
5.         If .Row = 1 And Target <> "" Then
   
6.             Set rng1 = Sheet1.Cells.Find(What:=.Value, LookIn:=xlValues, LookAt:=xlWhole)
   
7.             arr = rng1.Offset(1, 0).Resize(9, 1)
   
8.             .Offset(1, 0) = "表1"
   
9.             .Offset(2, 0).Resize(9, 1) = arr
   
10.             Set rng1 = Sheet2.Cells.Find(What:=.Value, LookIn:=xlValues, LookAt:=xlWhole)
    
11.             brr = rng1.Offset(1, 0).Resize(9, 1)
    
12.             .Offset(1, 1) = "表2"
    
13.             .Offset(2, 1).Resize(9, 1) = brr
    
14.         End If
    
15.     End With
    
16.     Cancel = True
    
17. End Sub

复制代码

一片薄云

ppp710715 发表于 2016-6-12 09:08

非常感谢！完美解决了我的问题！

一片薄云

ppp710715 发表于 2016-6-12 09:08

非常感谢帮忙！

ppp710715

不客气。互相学习。