[已解决]EXCEL数提取的问题

djsd1016

请各位朋友帮帮忙，我想通过在查询表中输入责任人的姓名查询出与该责任人相关的所有业务单据，不知如何来做，现将数据传上来希望各位不吝赐教，谢谢了！

最佳答案

月排行榜 / 总排行榜

放浪形骸

2011-8-14 00:58

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim iCnt As Integer
   
3. Dim sNme As String
   
4. Dim iCur As Integer
   
5. Dim iMaxRw As Integer
   
6. If Target.Row = 1 And Target.Column = 2 Then
   
7.     sNme = Sheet1.Cells(1, 2).Value
   
8.     iCur = 3
   
9.     Sheet1.Range("A1").CurrentRegion.Offset(2, 0).Clear
   
10.     iMaxRw = Sheet2.Range("B65536").End(xlUp).Row
    
11.         For iCnt = 1 To iMaxRw
    
12.         If Sheet2.Cells(iCnt, 8) = sNme Then
    
13.             Sheet1.Cells(iCur, 1).Value = Sheet2.Cells(iCnt, 2).Value
    
14.             Sheet1.Cells(iCur, 2).Value = Sheet2.Cells(iCnt, 3).Value
    
15.             Sheet1.Cells(iCur, 3).Value = Sheet2.Cells(iCnt, 4).Value
    
16.             Sheet1.Cells(iCur, 4).Value = Sheet2.Cells(iCnt, 5).Value
    
17.             Sheet1.Cells(iCur, 5).Value = Sheet2.Cells(iCnt, 6).Value
    
18.             Sheet1.Cells(iCur, 6).Value = Sheet2.Cells(iCnt, 7).Value
    
19.             Sheet1.Cells(iCur, 7).Value = Sheet2.Cells(iCnt, 9).Value
    
20.             Sheet1.Cells(iCur, 8).Value = Sheet2.Cells(iCnt, 10).Value
    
21.             iCur = iCur + 1
    
22.         End If
    
23.         Next
    
24. End If
    
25. End Sub

复制代码

将这段代码放到sheet1的Worksheet_Change事件中。

PS：查询里的I列也是“科目”是否重复？
我这里没有给其添加内容

跳转到最佳答案楼层

放浪形骸

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim iCnt As Integer
   
3. Dim sNme As String
   
4. Dim iCur As Integer
   
5. Dim iMaxRw As Integer
   
6. If Target.Row = 1 And Target.Column = 2 Then
   
7.     sNme = Sheet1.Cells(1, 2).Value
   
8.     iCur = 3
   
9.     Sheet1.Range("A1").CurrentRegion.Offset(2, 0).Clear
   
10.     iMaxRw = Sheet2.Range("B65536").End(xlUp).Row
    
11.         For iCnt = 1 To iMaxRw
    
12.         If Sheet2.Cells(iCnt, 8) = sNme Then
    
13.             Sheet1.Cells(iCur, 1).Value = Sheet2.Cells(iCnt, 2).Value
    
14.             Sheet1.Cells(iCur, 2).Value = Sheet2.Cells(iCnt, 3).Value
    
15.             Sheet1.Cells(iCur, 3).Value = Sheet2.Cells(iCnt, 4).Value
    
16.             Sheet1.Cells(iCur, 4).Value = Sheet2.Cells(iCnt, 5).Value
    
17.             Sheet1.Cells(iCur, 5).Value = Sheet2.Cells(iCnt, 6).Value
    
18.             Sheet1.Cells(iCur, 6).Value = Sheet2.Cells(iCnt, 7).Value
    
19.             Sheet1.Cells(iCur, 7).Value = Sheet2.Cells(iCnt, 9).Value
    
20.             Sheet1.Cells(iCur, 8).Value = Sheet2.Cells(iCnt, 10).Value
    
21.             iCur = iCur + 1
    
22.         End If
    
23.         Next
    
24. End If
    
25. End Sub

复制代码

将这段代码放到sheet1的Worksheet_Change事件中。

PS：查询里的I列也是“科目”是否重复？
我这里没有给其添加内容

fjmxwrs

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim arr, arr1(), y&, x&, i&
   
3. If Target.Address = "$B$1" Then
   
4. With Sheets("数据")
   
5. arr = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Value
   
6. End With
   
7. For x = 1 To UBound(arr)
   
8. If arr(x, 8) = Target.Value Then
   
9. i = i + 1
   
10. ReDim Preserve arr1(1 To 9, 1 To i)
    
11. For y = 1 To 7
    
12. arr1(y, i) = arr(x, y)
    
13. Next y
    
14. arr1(8, i) = arr(x, 9)
    
15. arr1(9, i) = arr(x, 10)
    
16. End If
    
17. Next x
    
18. Range("A3").Resize(65534, 9).ClearContents
    
19. Range("A3").Resize(65534, 9).Borders.LineStyle = 0
    
20. Range("A3").Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
21. Range("A3").Resize(UBound(arr1, 2), UBound(arr1)).Borders.LineStyle = 1
    
22. End If
    
23. End Sub
    
24. 
    
25. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
26. Dim arr, d As Object
    
27. Set d = CreateObject("scripting.dictionary")
    
28. If Target.Address = "$B$1" Then
    
29. With Sheets("数据")
    
30. arr = .Range("H2:H" & .Range("H65536").End(xlUp).Row)
    
31. End With
    
32. For x = 1 To UBound(arr)
    
33. d(arr(x, 1)) = ""
    
34. Next x
    
35. With Selection.Validation
    
36. .Delete
    
37. .Add Type:=xlValidateList, Formula1:=Join(d.keys, ",")
    
38. End With
    
39. End If
    
40. End Sub
    

复制代码

pn.rar (71.24 KB, 下载次数: 11)

2011-8-14 03:22 上传

点击文件名下载附件
单元格事件完成
1.点击B1时自动生成下拉序列
2.选择姓名时，自动提取姓名数据
3.表格边框线设置。

djsd1016

二楼、三楼的朋友做得都很好，我都试过了。谢谢你们。