按某列相同的值分到各工作表中

这个是近期常遇见的一个问题题，大意是这样的：

有一个总表，总表中包含N行标题列与M行数据，要将其中一列数据（比如A列）中相同值对应的行，分配到新工作表中。

如果数据量少的话，我们可以用筛选，再将结果复制到新工作表来完成，但数据一多，我们还是用VBA来完成吧：）。

首先，选择标题最后一行与条件数据所在列的单元格，比如共有3行标题，按第二列分配数据，就选择B3格，然后运行下面的宏：

Sub 按某列相同的值分到各工作表中()
On Error Resume Next
Dim I As Integer, N As Integer
Dim SR As Integer, ER As Integer, FC As Integer
Dim TS As String, SS As String
Dim OS As Worksheet, NS As Worksheet, KS As Worksheet
Set OS = ActiveSheet
FC = ActiveCell.Column
SR = ActiveCell.Row + 1
ER = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
For I = SR To ER
    TS = Cells(I, FC)
    If WorksheetFunction.CountIf(Range(Cells(SR, FC), Cells(I, FC)), TS) = 1 Then
        Set NS = ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
        N = 0
        Do
            If N Then
                SS = TS & "(" & N & ")"
            Else
                SS = TS
            End If
            Set KS = Worksheets(SS)
            If KS Is Nothing Then
                NS.Name = SS
                Exit Do
            Else
                Set KS = Nothing
            End If
            N = N + 1
        Loop
        OS.Select
        Rows(SR - 1).Select
        Selection.AutoFilter
        Selection.AutoFilter Field:=FC, Criteria1:=TS
        ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy
        NS.Select
        ActiveSheet.Paste
        OS.Select
        Selection.AutoFilter
    End If
Next
Cells(SR - 1, FC).Select
Application.ScreenUpdating = True
End Sub

运行宏后的结果——生成的工作表以数据为名称，如果存在，则为原来的名称加“(N)”，工作表按原来的顺序排列在最后。附上实例（包含上面的宏）按某列相同的值分到各工作表中.rar

最后是格式问题，宏生成的表，行高与列宽都变了，如果需要设定格式：

1、设定列宽：
选择原总表，复制，再选择所有生成的工作表，最后用选择性粘贴——列宽即可。
2、设定标题的行高：
选择原总表的标题，复制，再选择所有生成的工作表，选择标题列，再粘贴，就处理完了。

这不？是不是又快又省事呀！