前言

假如需要从一个Excel表中按照指定条件筛选，将筛选后数据复制到新的sheet中。如下图所示，需要将明细表按照客户拆分成各个Sheet，假如客户上百个，一个个手工去筛选复制后粘贴到新的sheet，不符合能自动就自动的精神。所以想到利用VBA实现，毕竟VBA是最好的Excel语言。

vba之筛选复制并新建sheet - 图1

但是由于不太会VBA，从网上了解了VBA中的AutoFilter以及for循环用法，通过录制宏以及修改实现了想要结果。代码记录如下：

  1. Sub 筛选()
  2. Dim i As Integer
  4. '开始循环
  5. For i = 2 To 10
  6. Sheets("明细").Select
  8. ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=Sheet2.Cells(i, 1)
  9. Range("A1:BK216").Select
  10. 'Range("A1").Activate
  11. Application.CutCopyMode = False
  12. Selection.Copy
  13. Sheets.Add After:=ActiveSheet
  14. ActiveSheet.Paste
  16. '给新的sheet重新命名
  17. Sheets("Sheet" & i).Select
  18. Sheets("Sheet" & i).Name = Sheet2.Cells(i, 1)
  19. Next
  21. End Sub

解决思路

拿到这个问题时，第一反应是用编程语言并不太好解决该问题。当涉及到Excel问题时，R或者Python往往并不是最优解决方案。所以，我试着想录制宏能不能解决，录制好的宏如下：

Sub 筛选()
    ActiveSheet.Range("$A$2:$V$522").AutoFilter Field:=1, Criteria1:="a"
    Range("A1:V522").Select
    Range("E6").Activate
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "a"

    Sheets("明细").Select
    ActiveSheet.Range("$A$2:$V$522").AutoFilter Field:=1, Criteria1:="b"
    Application.CutCopyMode = False
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "b"

    Sheets("明细").Select
    ActiveSheet.Range("$A$2:$V$522").AutoFilter Field:=1, Criteria1:="c"
    Application.CutCopyMode = False
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "c"
    Sheets("明细").Select
End Sub

通过观察上面的宏代码，发现代码中的三段是重复有规律，所以我们利用循环即可达到我们想要的效果。

其中筛选的条件a,b,c不断在变化，我们可以通过设定一个变量。如新建一个sheet1，将所有可能出现的变量存在sheet1中A列中，在循环中利用a = A1,b = B2,c= A3代替。改造后的代码如下：

Sub 筛选()
Dim i As Integer

'开始循环
For i = 2 To 27
Sheets("明细").Select

ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=Sheet1.Cells(i, 1)
Range("A1:BK216").Select
'Range("A1").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste

'给新的sheet重新命名
Sheets("Sheet" & i).Select
Sheets("Sheet" & i).Name = Sheet1.Cells(i, 1)
Next

End Sub

需要主要i的起始位置，每个Excel新增的sheet的名称是按照自然数字排序的sheet１、sheet２、sheet３；

演示