[已解决]求教设计一个提取清单

wingotoo

如图 我有一个sheet数据表

人员编号是文本

然后我在提取值里面输入


通过一个宏按钮就可以生成名字为 提取清单1的sheet，并筛选出此时A1显示的（113编号）的所有数据。如下图


请老师指点
如何提取清单.rar (7.88 KB, 下载次数: 10)

2015-5-30 16:26 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

as0810114

2015-5-30 17:00

1. Sub 提取()
   
2.     Application.DisplayAlerts = False
   
3.     Dim arr, brr(1 To 100000, 1 To 10)
   
4.     Dim irow, icol, k
   
5.     arr = Sheets("数据表").Range("a1").CurrentRegion
   
6.     For Each Sheet In Sheets
   
7.         If Sheet.Name = Sheets("提取值").Range("B1") Then Sheet.Delete
   
8.     Next
   
9.     Sheets.Add after:=Sheets(Sheets.Count)
   
10.     Sheets(Sheets.Count).Name = Sheets("提取值").Range("B1")
    
11.     Sheets("数据表").Range("a1:j1").Copy Sheets(Sheets.Count).Range("a1")
    
12.     For irow = 2 To UBound(arr)
    
13.         If arr(irow, 2) - Sheets("提取值").Range("A1") = 0 Then
    
14.             k = k + 1
    
15.             For icol = 1 To UBound(arr, 2)
    
16.                 brr(k, icol) = arr(irow, icol)
    
17.             Next
    
18.         End If
    
19.     Next
    
20.     Sheets(Sheets.Count).Range("A2").Resize(irow, 10) = brr
    
21.     Application.DisplayAlerts = True
    
22. End Sub

复制代码

跳转到最佳答案楼层

as0810114

1. Sub 提取()
   
2.     Application.DisplayAlerts = False
   
3.     Dim arr, brr(1 To 100000, 1 To 10)
   
4.     Dim irow, icol, k
   
5.     arr = Sheets("数据表").Range("a1").CurrentRegion
   
6.     For Each Sheet In Sheets
   
7.         If Sheet.Name = Sheets("提取值").Range("B1") Then Sheet.Delete
   
8.     Next
   
9.     Sheets.Add after:=Sheets(Sheets.Count)
   
10.     Sheets(Sheets.Count).Name = Sheets("提取值").Range("B1")
    
11.     Sheets("数据表").Range("a1:j1").Copy Sheets(Sheets.Count).Range("a1")
    
12.     For irow = 2 To UBound(arr)
    
13.         If arr(irow, 2) - Sheets("提取值").Range("A1") = 0 Then
    
14.             k = k + 1
    
15.             For icol = 1 To UBound(arr, 2)
    
16.                 brr(k, icol) = arr(irow, icol)
    
17.             Next
    
18.         End If
    
19.     Next
    
20.     Sheets(Sheets.Count).Range("A2").Resize(irow, 10) = brr
    
21.     Application.DisplayAlerts = True
    
22. End Sub

复制代码

jymydms

下载参考学习学习！！