Excel根据一个条件将一个表分成几个表.docVIP

Excel根据一个条件将一个表分成几个表 Sub hjs() Dim irow, irow1, i, j As Integer Dim H As New Collection Dim sht As Worksheet Dim A Dim ICol Sheets(1).Name = 总表 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 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 建立一个不重复的筛选条件 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 j = 2 To irow1 Cells(j, ICol) = Right(Cells(j, ICol), Len(Cells(j, ICol))) 消除新工作表文本符号 Next j .Cells.AutoFilter Debug.Print H(i) Next i .Delete 操作表此时已多余，故删除 End With A.Parent.Activate 激活汇总表的原来激活的单元格 A.Activate Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub