按某列相同的值分到各工作表中(3页).doc

-按某列相同的值分到各工作表中-第 3 页这个是近期常遇见的一个问题题，大意是这样的：有一个总表，总表中包含N行标题列与M行数据，要将其中一列数据（比如A列）中相同值对应的行，分配到新工作表中。如果数据量少的话，我们可以用筛选，再将结果复制到新工作表来完成，但数据一多，我们还是用VBA来完成吧：）。首先，选择标题最后一行与条件数据所在列的单元格，比如共有3行标题，按第二列分配数据，就选择B3格，然后运行下面的宏：Sub 按某列相同的值分到各工作表中()On Error Resume NextDim I As Integer, N As IntegerDim SR As Integer, ER As Integer, FC As IntegerDim TS As String, SS As StringDim OS As Worksheet, NS As Worksheet, KS As WorksheetSet OS = ActiveSheetFC = ActiveCell.ColumnSR = ActiveCell.Row + 1ER = ActiveCell.SpecialCells(xlCellTypeLastCell).RowApplication.ScreenUpdating = FalseFor 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 IfNextCells(SR - 1, FC).SelectApplication.ScreenUpdating = TrueEnd Sub运行宏后的结果生成的工作表以数据为名称，如果存在，则为原来的名称加“(N)”，工作表按原来的顺序排列在最后。附上实例（包含上面的宏）最后是格式问题，宏生成的表，行高与列宽都变了，如果需要设定格式：1、设定列宽：选择原总表，复制，再选择所有生成的工作表，最后用选择性粘贴列宽即可。 2、设定标题的行高：选择原总表的标题，复制，再选择所有生成的工作表，选择标题列，再粘贴，就处理完了。这不？是不是又快又省事呀！