如何提取整个工作簿里所有符合条件的数据所在的整行，提取到新表中

sakura2014

如提取文件中专业为  不限 的所有行  到新的工作表中 2014年江苏公务员考试职位表.zip (284.53 KB, 下载次数: 393)

2014-2-12 21:16 上传

点击文件名下载附件
发

xutianlin

1. Sub 提取数据()
   
2. On Error Resume Next
   
3. Dim wsh As Worksheet, i As Integer, brr(), j As Integer, arr
   
4. For Each wsh In Worksheets
   
5. If wsh.Name = "提取数据" Then GoTo 100
   
6. j = wsh.Range("a65536").End(xlUp).Row
   
7. arr = wsh.Range("a5:n" & j)
   
8. k = k + UBound(arr)
   
9. ReDim Preserve brr(1 To 14, 1 To k)
   
10. For i = 1 To UBound(arr)
    
11. If arr(i, 13) = "不限" Then
    
12. n = n + 1
    
13. brr(1, n) = arr(i, 1)
    
14. brr(2, n) = arr(i, 2)
    
15. brr(3, n) = arr(i, 3)
    
16. brr(4, n) = arr(i, 4)
    
17. brr(5, n) = arr(i, 5)
    
18. brr(6, n) = arr(i, 6)
    
19. brr(7, n) = arr(i, 7)
    
20. brr(8, n) = arr(i, 8)
    
21. brr(9, n) = arr(i, 9)
    
22. brr(10, n) = arr(i, 10)
    
23. brr(11, n) = arr(i, 11)
    
24. brr(12, n) = arr(i, 12)
    
25. brr(13, n) = arr(i, 13)
    
26. brr(14, n) = arr(i, 14)
    
27. End If
    
28. Next
    
29. 100:
    
30. Next
    
31. Sheets("提取数据").Range("a2").Resize(n, 14) = Application.WorksheetFunction.Transpose(brr)
    
32. End Sub

复制代码

祝洪忠-

【数据】【筛选】 专业所在列筛选条件为“不限”，选择数据区域 按F5 定位  定位条件可见单元格  复制到指定位置 粘贴即可

sakura2014

xutianlin 发表于 2014-2-12 21:33

你真热心肠，万分感谢 ，请问如果是专业 含有“法律”的关键字如何实现呢

xutianlin

1. Sub 提取数据()
   
2. On Error Resume Next
   
3. Dim wsh As Worksheet, i As Integer, brr(), j As Integer, arr
   
4. For Each wsh In Worksheets
   
5. If wsh.Name = "提取数据" Then GoTo 100
   
6. j = wsh.Range("a65536").End(xlUp).Row
   
7. arr = wsh.Range("a5:n" & j)
   
8. k = k + UBound(arr)
   
9. ReDim Preserve brr(1 To 14, 1 To k)
   
10. For i = 1 To UBound(arr)
    
11. If arr(i, 13) Like "*法律*" Then'这里改一下就好了
    
12. n = n + 1
    
13. brr(1, n) = arr(i, 1)
    
14. brr(2, n) = arr(i, 2)
    
15. brr(3, n) = arr(i, 3)
    
16. brr(4, n) = arr(i, 4)
    
17. brr(5, n) = arr(i, 5)
    
18. brr(6, n) = arr(i, 6)
    
19. brr(7, n) = arr(i, 7)
    
20. brr(8, n) = arr(i, 8)
    
21. brr(9, n) = arr(i, 9)
    
22. brr(10, n) = arr(i, 10)
    
23. brr(11, n) = arr(i, 11)
    
24. brr(12, n) = arr(i, 12)
    
25. brr(13, n) = arr(i, 13)
    
26. brr(14, n) = arr(i, 14)
    
27. End If
    
28. Next
    
29. 100:
    
30. Next
    
31. Sheets("提取数据").Range("a2").Resize(n, 14) = Application.WorksheetFunction.Transpose(brr)
    
32. End Sub

复制代码

sakura2014

xutianlin 发表于 2014-2-12 21:55

那如果判别语句含有多个条件如何呢 ，学历为研究生，专业为不限呢

xutianlin

1. Sub 提取数据()
   
2. On Error Resume Next
   
3. Dim wsh As Worksheet, i As Integer, brr(), j As Integer, arr
   
4. For Each wsh In Worksheets
   
5. If wsh.Name = "提取数据" Then GoTo 100
   
6. j = wsh.Range("a65536").End(xlUp).Row
   
7. arr = wsh.Range("a5:n" & j)
   
8. k = k + UBound(arr)
   
9. ReDim Preserve brr(1 To 14, 1 To k)
   
10. For i = 1 To UBound(arr)
    
11. If arr(i, 13) = "不限" And arr(i, 12) = "研究生" Then
    
12. n = n + 1
    
13. brr(1, n) = arr(i, 1)
    
14. brr(2, n) = arr(i, 2)
    
15. brr(3, n) = arr(i, 3)
    
16. brr(4, n) = arr(i, 4)
    
17. brr(5, n) = arr(i, 5)
    
18. brr(6, n) = arr(i, 6)
    
19. brr(7, n) = arr(i, 7)
    
20. brr(8, n) = arr(i, 8)
    
21. brr(9, n) = arr(i, 9)
    
22. brr(10, n) = arr(i, 10)
    
23. brr(11, n) = arr(i, 11)
    
24. brr(12, n) = arr(i, 12)
    
25. brr(13, n) = arr(i, 13)
    
26. brr(14, n) = arr(i, 14)
    
27. End If
    
28. Next
    
29. 100:
    
30. Next
    
31. Sheets("提取数据").Range("a2").Resize(n, 14) = Application.WorksheetFunction.Transpose(brr)
    
32. End Sub

复制代码

缔造者

sakura2014 发表于 2014-2-12 22:02
那如果判别语句含有多个条件如何呢 ，学历为研究生，专业为不限呢

多条件判断用and

sakura2014

您真是大神，但这样提取的表格格式很乱，能不能调整 已提取表格的格式 同原表格一致

xutianlin

no...................................................