拆分一个单元表为多个单元簿

方案1（数据透视表实现）

• “数据透视表”按指定字段统计，获得数据透视表

• 点击数据透视表中指定字段的值打开对应值的明细表

• 批量修改已打开的工作表名

  Sub changename()
  MsgBox “共有sheets” & Worksheets.Count & “个”
  For i = 9 To (Worksheets.Count)
  nname = Worksheets(i).Range(“B2”).Value ‘Range(“B2”)为要作为表名的单元格的位置
  If nname <> “” Then
  Worksheets(i).Name = nname
  Else
  MsgBox “此处为空”
  Worksheets(i).Name = “default”
  End If
  Next
  MsgBox “done!”
  End Sub

• 拆分工作表为多个工作簿（同样适用于方案二）

  Sub Splitbook()
  Dim xPath As String ‘工作簿所在路径
  xPath = Application.ActiveWorkbook.Path ‘赋值为当前活跃工作簿所在位置
  Application.ScreenUpdating = False ‘关闭更新以提高运行效率
  Application.DisplayAlerts = False ‘关闭关闭excel时弹出的提示框
  For Each xWs In ThisWorkbook.Sheets ‘遍历工作簿中的工作表
  xWs.Copy ‘复制工作表
  Application.ActiveWorkbook.SaveAs Filename:=xPath & “\” & xWs.Name & “.xls” ‘保存工作表到当前工作簿所在目录
  Application.ActiveWorkbook.Close False ‘关闭工作簿但不保存
  Next
  Application.DisplayAlerts = True ‘恢复设置
  Application.ScreenUpdating = True
  End Sub

方案2（待实现.用VBA实现）

• 选取待拆分工作表中关键字列
• 创建一个字典对象，用来存储关键字值与其统计

• 遍历关键字列

  • 每当有新值出现

    • 在字典中插入一组键值对
    • 以该值为表名在当前表之后新建一个工作表
    • 同时复制当前行到新表,代码如下
      '复制行到目标位置（取首个单元格即可）
sheets("oldsheet").range(cells(2,1),cells(2,lastcolumn)).copy _destination:= sheets("newsheet").range[cells(2,1)]
'获取主表最后一列非空列的列序号
lastcolumn = sheets("oldsheet").cells(2,225).end(xlToLeft).column
'获取主表最后一行非空行的行序号
lastrow = sheets("oldsheet").cells(65536,1).end(xlUP).row


  • 遍历到的值在字典中已存在key,则对应item加1，同时复制该行到对应表的非空的最后一行之后

• 拆分单元表到单元簿（同方案1最后一步）

方案3（用ADO和SQL直接查询拆分）