【转载】EXCEL VBA 工作表拆分

用VBA拆分工作表是一个不错的方法，特别是在处理大量数据的时候，能节省不少时间。

 

1、高级筛选：

筛选并复制到新工作表的关键代码如下：

Range("Database").AdvancedFilter _

    Action:=xlFilterCopy, _

   CriteriaRange:=Range("Criteria"), _

   CopyToRange:=Range("Paste"), _

    Unique:=False

该代码执行结果是将Database区域的数据按照Criteria区域条件筛选，并粘贴到Paste区域。

 

AdvancedFilter(Action, [CriteriaRange], [CopyToRange], [Unique])是VBA中对Range对象进行筛选的方法：Action参数可以填xlFilterInPlace或xlFilterCopy，前者是直接进行筛选，后者是我们这次用到的筛选并复制功能；CriteriaRange是筛选条件的区域；CopyToRange是粘贴到的区域（如果Action参数为xlFilterInPlace则不填）；Unique参数是布尔型，用来选择是否只保留一条重复记录。

 

这里需要详细说明的是CriteriaRange参数：

 

筛选条件区域至少为两行，首行为列标题，与原记录中的列标题要一致。

同一行中，各列之间是AND逻辑

不同行之间是OR逻辑

如果标题行不一致或者出现空行，则全选

因为CriteriaRange参数要求如此严格，所以我们在对表格数据进行筛选时会用两个临时单元格存放需要筛选的数据。

 

Sheet1.Range("ZZ2")  = critTitle

Sheet1.Range("ZZ3")  = critValue

 

这里为了防止干扰已有数据，把临时数据放在了702列，从第2行开始是为了不影响UsedRange的使用。如果觉得这样不保险也可以用以下方法来获取最后一行和最后一列：

 

Dim rowCount%, colCount%

colCount = Sheet1.Range("XFD1").End(xlToLeft).Column '获取最后一列

rowCount = Sheet1.Range("A1048576").End(xlUp).Row '获取最后一行

然后用Range(Cells(1, 1), Cells(rowCount, colCount))代替UsedRange，理论上这样是更符合逻辑的。

 

Sheet1.Range(Cells(1, 1), Cells(rowCount, colCount)).AdvancedFilter _

    Action:=xlFilterCopy, _

   CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _

   CopyToRange:=Range("Paste"), _

    Unique:=False

获取了数据来源、筛选条件，现在就差粘贴到的新工作表了。

 

2、新建工作表

 

新建工作表的代码很简单：

 

Sheets.Add

 

Add([Before], [After], [Count], [Type])方法的4个可选参数分别代表：在指定工作表之前新建、在指定工作表之后新建、新建工作表数量、新建工作表类型。

 

一般我们把总表放在第一个，会用：

 

Sheets.Add after:=Sheet1

ActiveSheet.Name = critValue

工作表新建后会自动激活，所以我们可以用ActiveSheet.Name给新建工作表重命名。需要注意的是，工作表的名称不能重复，不能超过31个字符，也不能包含一些特殊字符。这里提供一个清除字符串中特殊字符的函数，用来保证新建工作表的名字符合要求：

 

Function sheetNamePack(ByVal sheetName As String) As String

'工作表名标准化

Dim x, i

sheetNamePack = ""

For i = 1 To Len(sheetName)

    x = Mid(sheetName, i, 1)

    If x <> "/" And x <> "\" And x <> "?" And x <> "*" And x <> "[" And x <> "]" And x <> ":" Then sheetNamePack = sheetNamePack & x

Next i

sheetNamePack = Left(sheetNamePack, 10) '为了美观只显示前10个字符

End Function

 

我们给工作表重命名的时候使用以下代码就能降低出错几率：

 

ActiveSheet.Name = sheetNamePack(critValue)

我们把新建工作表和筛选的代码封装成一个过程：

 

Sub filterData(critValue As String)

    Sheets.Add after:=Sheet1

    ActiveSheet.Name = sheetNamePack(critValue)

    Sheet1.Range("ZZ3") = critValue

    

    Sheet1.Activate '

   Sheet1.UsedRange.AdvancedFilter _

    Action:=xlFilterCopy, _

   CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _

   CopyToRange:=Worksheets(sheetNamePack(critValue)).Range("A1"), _

    Unique:=False

End Sub

 

这里的筛选部分比之前多了一个让Sheet1变成活动工作表的语句，因为新建工作表会成为活动工作表，而筛选方法必须在活动工作表中才能使用。而我们发现粘贴区域并不用判定大小，只要设置从A1单元格开始粘贴就可以了。

 

3、获取筛选条件

我们需要按某一维度筛选，首先要获取筛选条件的字段，为了让筛选操作更加简易，我们按照活动单元格所在的列进行筛选：

 

Dim col%

col = ActiveCell.Column 

critTitle = Sheet1.Cells(1, col)

要将所有内容分组按工作表分开，就要获取到该字段的所有唯一值。这里我们使用字典的方法来进行：

 

Dim arr, d, i%, temp

arr = Sheet1.Range(Cells(2, 1), Cells(rowCount, colCount))

Set d = CreateObject("scripting.dictionary")  '创建字典

For i = 1 To UBound(arr) '初始化字典，去重+计数

    If d.exists(arr(i, col)) Then

       d(arr(i, col)) = d(arr(i, col)) + 1

    Else

       d(arr(i, col)) = 1

    End If

Next

temp = d.keys '临时变量赋值

 

用字段内容作为字典的key，字段值出现的次数作为item，这样既把唯一值提取出来又记录了个数。现在d这个字典的内容就和上面数据透视表的图是一样的了。注：这里的arr也可以用UsedRange加Resize方法和Offset方法来获取除标题行外的数据。

 

然后遍历一下字典的数据，就得到我们想要的结果了：

 

For i = 1 To d.Count

    critValue = temp(i - 1)

    Call filterData(critValue)

Next i

最后记得把临时单元格清空：

 

Sheet1.Range("ZZ2:ZZ3").ClearContent

 

4、附加功能

 

增加数值筛选

 

通过字典计数的数据我们也可以利用起来，比如如果想要把数量多于某一临界值的数据分表列出，就可以在创建字典前输入一个数字：

 

Dim num$

num = InputBox("请输入筛选值，数量大于该数值的内容将被筛选。（输入为空则默认为0）", "输入数字", 0)  '获取筛选值

If StrPtr(num) = 0 Then Exit Sub '点击取消退出

If num = "" Then num = "0"      '输入为空则默认为0

If IsNumeric(num) = False Then MsgBox "请输入数字！": Exit Sub  '输入非数字

然后在筛选前和d(temp(i - 1)做比较：

 

If d(temp(i - 1)) >= CInt(num) Then Call filterData(critValue)

 

屏蔽刷新

 

我们一般会在宏的第一条语句之前加一个关闭实时刷新的命令，在最后一条语句之后再恢复，这样做可以优化运行速度。

 

Sub close_Application()

'关闭刷新功能

    With Application

       .ScreenUpdating = False

       .DisplayAlerts = False

       .EnableEvents = False

       .Calculation = xlCalculationManual

    End With

End Sub

 

Sub open_Application()

'打开刷新功能

    With Application

       .ScreenUpdating = True

       .DisplayAlerts = True

       .EnableEvents = True

       .Calculation = xlCalculationAutomatic

    End With

End Sub

 

删除多余工作表

 

在调试的时候会产生很多新工作表，一个个删除很耽误时间，在执行筛选时如果遇到错误我们也需要进行回滚，删除多出的工作表。

 

Sub clear_Sheets(Optional sheetCount As Integer = 1)

'清除工作表

Call close_Application

Dim i As Integer

For i = Sheets.Count To sheetCount + 1 Step -1

  Sheets(i).Delete

Next i

Call open_Application

End Sub

 

利用Excel+VBA进行工作表的拆分大致就是这样的过程， 整体代码放在附录中，仅供参考。

 

附录：代码部分

Sub data_Partition;()

Call close_Application

 

'获取筛选数值

Dim num$

num = InputBox("请输入筛选值，数量大于该数值的内容将被筛选。（输入为空则默认为0）", "输入数字", 0)  '获取筛选值

If StrPtr(num) = 0 Then Exit Sub '点击取消退出

If num = "" Then num = "0"      '输入为空则默认为0

If IsNumeric(num) = False Then MsgBox "请输入数字！": Exit Sub  '输入非数字

 

'获取筛选条件

Dim critTitle$, critValue$, col%

col = ActiveCell.Column

critTitle = Sheet1.Cells(1, col)

Sheet1.Range("ZZ2") = critTitle

 

Dim rowCount%, colCount%

colCount = Sheet1.Range("XFD1").End(xlToLeft).Column

rowCount = Sheet1.Range("A1048576").End(xlUp).Row

 

'字典功能去重+计数

Dim arr, d, i%, temp

arr = Sheet1.Range(Cells(2, 1), Cells(rowCount, colCount))

Set d = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(arr)

    If d.exists(arr(i, col)) Then

       d(arr(i, col)) = d(arr(i, col)) + 1

    Else

     d(arr(i, col)) = 1

    End If

Next

temp = d.keys

 

'遍历字典

For i = 1 To d.Count

    critValue = temp(i - 1)

    '新建工作表并筛选

    If d(temp(i - 1)) >= CInt(num) Then Call filterData(critValue)

Next i

Sheet1.Range("zz2:zz3").ClearContents

 

Call open_Application

End Sub

Function sheetNamePack(ByVal sheetName As String) As String

'工作表名标准化

Dim x, i

sheetNamePack = ""

For i = 1 To Len(sheetName)

    x = Mid(sheetName, i, 1)

    If x <> "/" And x <> "\" And x <> "?" And x <> "*" And x <> "[" And x <> "]" And x <> ":" Then sheetNamePack = sheetNamePack & x

Next i

sheetNamePack = Left(sheetNamePack, 20)

End Function

Sub filterData(critValue As String)

 

    Sheets.Add after:=Sheet1

    ActiveSheet.Name = sheetNamePack(critValue)

    Sheet1.Range("ZZ3") = critValue

    

    Sheet1.Activate

   Sheet1.UsedRange.AdvancedFilter _

    Action:=xlFilterCopy, _

   CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _

   CopyToRange:=Worksheets(sheetNamePack(critValue)).Range("A1"), _

    Unique:=False

End Sub

 

Sub close_Application()

'关闭刷新功能

    With Application

       .ScreenUpdating = False

       .DisplayAlerts = False

       .EnableEvents = False

       .Calculation = xlCalculationManual

    End With    

End Sub

 

Sub open_Application()

'打开刷新功能

    With Application

       .ScreenUpdating = True

       .DisplayAlerts = True

       .EnableEvents = True

       .Calculation = xlCalculationAutomatic

    End With

End Sub