大家好，今天跟大家分享一个表格拆分案例，具体如下：
原表及需求：
需求：根据二维表按照SKU拆分为多个一维表
拆分示例：
1）一共10个SKU，需拆分为10个表，每个SKU一个表
2）每个SKU表包含几列信息：SKU,车系，车型，城市，车架号
3）每个SKU表的行数根据SKU与城市的交叉数据确定，例如SKU为116的车，拆分完毕后有19行，其中成都3行，重庆3行……长春3行，其他SKU表同理
拆分结果展示：
代码解析：
Sub 生成()
'不提示消息框，因为删除表格时有提示，因此先关闭
Application.DisplayAlerts = False
'关闭屏幕刷新
Application.ScreenUpdating = False
'删除“二维表”以外的其他表格
'遍历每一个工作表
For Each na In ThisWorkbook.Sheets
'如果工作表的名字不等于“二维表”即删除
If na.Name <> "二维表" Then
na.Delete
End If
Next
'获取二维表的行数即列数
MyRow = Sheets("二维表").Cells(Rows.Count, 1).End(xlUp).Row
MyColumn = Sheets("二维表").Cells(1, Columns.Count).End(xlToRight).Column
'根据SKU的个数增加表,并将表的名字命名为SKU
'第一次增加的表在“二维表”后，后面的表格依次往后添加
For i = 2 To MyRow
If i = 2 Then
Sheets.Add After:=Sheets("二维表")
ActiveSheet.Name = Sheets("二维表").Cells(i, 1).Value
Else:
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = Sheets("二维表").Cells(i, 1).Value
End If
'设置表头
ActiveSheet.Range("A1").Value = "序号"
ActiveSheet.Range("b1").Value = "车系"
ActiveSheet.Range("C1").Value = "车型"
ActiveSheet.Range("D1").Value = "城市"
ActiveSheet.Range("E1").Value = "车架号"
'按城市循环（列循环)
For j = 4 To MyColumn
'当车辆数据不为0时，就按照实际数据增加行数
If Sheets("二维表").Cells(i, j).Value <> 0 Then
'取得城市与SKU的交叉数据，即车辆个数，定义为CarNum
CarNum = Sheets("二维表").Cells(i, j).Value
'取得城市名称
city = Sheets("二维表").Cells(1, j).Value
'取得当前表格的行数
ActiveRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'根据车辆个数，在A列增加序号
For y = 1 To CarNum
ActiveSheet.Range("A" & ActiveRow + y).Value = y
Next
'在BCDE列增加车辆信息，整列增加
ActiveSheet.Range("B" & ActiveRow + 1 & ":B" & ActiveRow + CarNum).Value = Sheets("二维表").Cells(i, 2).Value
ActiveSheet.Range("C" & ActiveRow + 1 & ":C" & ActiveRow + CarNum).Value = Sheets("二维表").Cells(i, 3).Value
ActiveSheet.Range("D" & ActiveRow + 1 & ":D" & ActiveRow + CarNum).Value = Sheets("二维表").Cells(1, CarNum).Value
ActiveSheet.Range("E" & ActiveRow + 1 & ":E" & ActiveRow + CarNum).Value = ""
End If
Next
'自动适应列宽
Cells.EntireColumn.AutoFit
Next
'文件另存
ThisWorkbook.SaveAs ThisWorkbook.Path & "\明细表-" & Format(Now, "yymmdd") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
'定位新建工作表到“二维表”页
ActiveWorkbook.Sheets("二维表").Select
'开启消息框提示及屏幕更新
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub
----------------------------------------
有QQ的小伙伴可以加群：930619156
还在为查找网上浩若繁星的代码发愁？快来识别以下二维码，关注VBA代码集锦，帮你总结注释高效实用代码。更有代码视频讲解及更多EXCEL讲解视频。