[已解决]针对条件取数

jiangslly

想通过读取条件把符合条件的记录读取出放到新的工作表中（条件：公司、一级部门、二级部门），其中字段项目要同时复制到新表中，具体见附件；要求：因为工资明细表涉及到多个归属公司，一级部门和二级部门，每个月都要手动分解明细发给各个区域，很麻烦，现在想求各位大神，能用VBA对条件进行取数，并放入新的工作表中（因为条件比较多，所以想能不能用弹出窗口的形式，然后选择条件区域，这样可以多次操作）谢谢了！

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-22 14:07

表一通过鼠标选中行，该行条件会自动到第3行作为筛选条件。然后点击按钮可得结果。

1. Sub 筛选()
   
2.     On Error Resume Next
   
3.     Sheets(3).Cells.Clear
   
4.     With Sheets("基础数据")
   
5.         .ShowAllData
   
6.         .Range("A2:AV" & .[a65536].End(3).Row).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
   
7.             Sheets("取数条件").Range("A2:D3"), Unique:=False
   
8.         .UsedRange.Copy Sheets(3).[a1]
   
9.     End With
   
10.     Sheets(3).Columns.AutoFit
    
11. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

表一通过鼠标选中行，该行条件会自动到第3行作为筛选条件。然后点击按钮可得结果。

1. Sub 筛选()
   
2.     On Error Resume Next
   
3.     Sheets(3).Cells.Clear
   
4.     With Sheets("基础数据")
   
5.         .ShowAllData
   
6.         .Range("A2:AV" & .[a65536].End(3).Row).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
   
7.             Sheets("取数条件").Range("A2:D3"), Unique:=False
   
8.         .UsedRange.Copy Sheets(3).[a1]
   
9.     End With
   
10.     Sheets(3).Columns.AutoFit
    
11. End Sub
    

复制代码

jiangslly

grf1973 发表于 2016-12-22 14:07
表一通过鼠标选中行，该行条件会自动到第3行作为筛选条件。然后点击按钮可得结果。

谢谢你，我想问下，如果同时两行条件，可以筛选吗？比如想把臻万跟广源的一起筛选出来，另外，想筛选出来后，就直接从后面增加一张表，不删除，可以实现吗？

jiangslly

grf1973 发表于 2016-12-22 14:07
表一通过鼠标选中行，该行条件会自动到第3行作为筛选条件。然后点击按钮可得结果。

大侠，我想问下，假如我想把筛选出的数据放入新的工作簿中，并以筛选条件命名工作簿，这样怎样写代码

grf1973

请看附件。作了一些条件的设置，自己琢磨吧。

jiangslly

grf1973 发表于 2016-12-23 10:38
请看附件。作了一些条件的设置，自己琢磨吧。

谢谢，现在还有个问题

Sub 汇总数据()

Dim wb As Workbook, sht As Worksheet, sh As Worksheet, i%, j%, k%, m%, n%
Dim CopyRng
Set wb = ThisWorkbook
For Each sh In wb.Sheets

If sh.Name <> "汇总" Then

m = sh.Range("b65536").End(xlUp).Row
With sh

Set CopyRng = Union(.Range("A" & 14 & ":c" & m), .Range("q" & 14 & ":q" & m))
End With
With Sheets("汇总")
CopyRng.Copy.["a" & .[a265536].End(3).Row + 1]
End With
End If
Next
End Sub

CopyRng.Copy.["a" & .[a265536].End(3).Row + 1]，这句话有什么语病？我运行到这里运行不下去了

grf1973

["a" & .[a265536].End(3).Row + 1] 改为 range（"a" & .[a65536].End(3).Row + 1）

jiangslly

grf1973 发表于 2016-12-23 13:12
["a" & .[a265536].End(3).Row + 1] 改为 range（"a" & .[a65536].End(3).Row + 1）

还是不行啊，说应用程序定义或对象定义错误，帮帮忙

grf1973

应该是少了句清空的吧
Set CopyRng = Nothing。不然把不同工作表的区域Union起来会出错的。

1. Sub 汇总数据()
   
2.     Dim wb As Workbook, sht As Worksheet, sh As Worksheet, i%, j%, k%, m%, n%
   
3.     Dim CopyRng
   
4.     Set wb = ThisWorkbook
   
5.     With Sheets("汇总")
   
6.         For Each sh In wb.Sheets
   
7.             If sh.Name <> "汇总" Then
   
8.                 m = sh.Range("b65536").End(xlUp).Row
   
9.                 Set CopyRng = Union(sh.Range("A14:c" & m), sh.Range("q14:q" & m))
   
10.                 CopyRng.Copy .Range("a" & .[a65536].End(3).Row + 1)
    
11.                 Set CopyRng = Nothing
    
12.             End If
    
13.         Next
    
14.     End With
    
15. End Sub

复制代码

jiangslly

grf1973 发表于 2016-12-23 14:01
应该是少了句清空的吧
Set CopyRng = Nothing。不然把不同工作表的区域Union起来会出错的。

我试过了，还是不行，要不我把表格发你？