《按某列相同的值分到各工作表中.doc》由会员分享，可在线阅读，更多相关《按某列相同的值分到各工作表中.doc（3页珍藏版）》请在taowenge.com淘文阁网|工程机械CAD图纸|机械工程制图|CAD装配图下载|SolidWorks_CaTia_CAD_UG_PROE_设计图分享下载上搜索。
1、如有侵权，请联系网站删除，仅供学习与交流按某列相同的值分到各工作表中【精品文档】第 3 页这个是近期常遇见的一个问题题，大意是这样的：有一个总表，总表中包含N行标题列与M行数据，要将其中一列数据（比如A列）中相同值对应的行，分配到新工作表中。如果数据量少的话，我们可以用筛选，再将结果复制到新工作表来完成，但数据一多，我们还是用VBA来完成吧：）。首先，选择标题最后一行与条件数据所在列的单元格，比如共有3行标题，按第二列分配数据，就选择B3格，然后运行下面的宏：Sub 按某列相同的值分到各工作表中()On Error Resume NextDim I As Integer, N As Integ
2、erDim 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
3、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.
4、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、设定标题的行高：选择原总表的标题，复制，再选择所有生成的工作表，选择标题列，再粘贴，就处理完了。这不？是不是又快又省事呀！