自动分表--EXCEL

Sub  hjs()
Dim  irow, irow1, i, j  As   Integer
Dim  H  As   New  Collection
Dim  sht  As  Worksheet
Dim  A
Dim  ICol

Set  A  =  ActiveCell
Application.ScreenUpdating  =   False
Application.DisplayAlerts  =   False
For   Each  sht In Sheets
  If  sht.Name  <>   " 总表 "   Then  sht.Delete               ' 删除所有分表
Next
Sheets( " 总表 " ).Copy Before: = Sheets( 1 )   ' 加入新表来操作，以防破坏原数据中的公式或格式
ICol  =  Application.InputBox( " 请输入你所要分的列：（如按B列分请输入2） " ,  " 提示： " ,  " 2 " , Type: = 1 )
If  ICol  =   ""   Then   Exit   Sub
Fneiwai  =  Application.InputBox( " 请确定是表内还是表外，A为表外，B为表内 " ,  " 提示： " ,  " B " )
If  Fneiwai  =   ""   Then   Exit   Sub

On   Error   Resume   Next
     With  Sheets( " 总表 (2) " )
        irow  =  .[a1].CurrentRegion.Rows.Count
         For  i  =   2   To  irow
           .Cells(i, ICol)  =   " ' "   &  .Cells(i, ICol)   ' 在原工作表生成文本符号
         Next
         For  i  =   2   To  irow
           H.Add .Cells(i, ICol),  CStr (.Cells(i, ICol))
         Next                                             ' 建立一个不重复的筛选条件
        
If  Fneiwai  =   " A "   Then             ' 表外分开
Path  =  Application.ActiveWorkbook.Path
   For  i  =   1   To  H.Count
    .Cells.AutoFilter field: = ICol, Criteria1: = H(i)
     Set  Nw  =  Workbooks.Add
    .[a1].CurrentRegion.Copy [a1]      ' 自动筛选，并复制到新建的表中
    irow1  =  [a1].CurrentRegion.Rows.Count
     For  t  =   1   To  [a1].CurrentRegion.Columns.Count
        Cells( 1 , t).ColumnWidth  =  .Cells( 1 , t).ColumnWidth
         Next  t                           ' 复制列宽
     For  j  =   2   To  irow1
       Cells(j, ICol)  =   Right (Cells(j, ICol),  Len (Cells(j, ICol)))  ' 消除新工作表文本符号
     Next  j
    Nw.SaveAs Filename: = Path  &   " "   &  H(i)  &   " .xls "
    Nw.Close  True
    .Cells.AutoFilter
   Next  i
  
  
ElseIf  Fneiwai  =   " B "   Then           ' 表内分开
   For  i  =   1   To  H.Count
    .Cells.AutoFilter field: = ICol, Criteria1: = H(i)
    Sheets.Add(After: = Sheets(Sheets.Count)).Name  =  H(i)
    .[a1].CurrentRegion.Copy Sheets( CStr (H(i))).[a1]      ' 自动筛选，并复制到新建的表中
    irow1  =  [a1].CurrentRegion.Rows.Count
     For  t  =   1   To  [a1].CurrentRegion.Columns.Count
        Cells( 1 , t).ColumnWidth  =  .Cells( 1 , t).ColumnWidth
         Next  t                           ' 复制列宽
     For  j  =   2   To  irow1
       Cells(j, ICol)  =   Right (Cells(j, ICol),  Len (Cells(j, ICol)))  ' 消除新工作表文本符号
     Next  j
    .Cells.AutoFilter
   Next  i
End   If

  
  .Delete  '  操作表此时已多余，故删除
   End   With
  
  A.Parent.Activate  ' 激活汇总表的原来激活的单元格
  A.Activate
    
Application.DisplayAlerts  =   True
Application.ScreenUpdating  =   True
End Sub

 源于:www.excelhome.net