用VBA实现
Sub 拆分工作簿()
Application.ScreenUpdating = False '关闭屏幕闪动,提速
Application.DisplayAlerts = False '关闭窗口提示
kk = 2
Set dic = CreateObject("scripting.dictionary")
With ThisWorkbook.Worksheets("Sheet1") '根据自己的工作簿自行修改
cln = InputBox("请输入需要按列拆分的列:" & Chr(10) & "英文列标", "输入列标", "A") 'inputbox提示输入需要拆分的列标
cln2 = .Range("a1").End(xlToRight).Column '获取最大列数,为了增加通用性
If .Range(cln & 2) = "" Then Exit Sub
rrow = .Cells(Rows.Count, cln).End(xlUp).Row
arr = WorksheetFunction.Transpose(.Range(cln & 1 & ":" & cln & rrow))
For i = 1 To UBound(arr) '将拆分条件列数据写入字典,为了去重复。
If Not dic.exists(arr(i)) Then '若字典中不存在该字符串,则写入。
dic.Add arr(i), .Range("a" & i).Resize(1, cln2)
Else
Set dic.Item(arr(i)) = Union(dic.Item(arr(i)), .Range("a" & i).Resize(1, cln2))
End If
Next
k = dic.keys
l = dic.items
For ss = 0 To dic.Count - 1
Set wb = Workbooks.Add '新建工作簿
With wb.Worksheets(1)
Rows(1).Copy ActiveSheet.Rows(1)
'l(ss).Copy .Range("a2")
l(ss).Copy .Range("a2")
ActiveSheet.Columns("D:D").ColumnWidth = 51
ActiveSheet.Rows("2:100").EntireRow.AutoFit
ActiveSheet.Columns("A:C").EntireColumn.AutoFit
ActiveSheet.Columns("E:P").EntireColumn.AutoFit
ActiveSheet.Columns("J:J").ColumnWidth = 33
'Sheets(1).Range("a2:a100").PasteSpecial Paste:=xlPasteFormats
'Worksheets("Sheet1").Range("a1:m1").Copy.Range ("a1:m1")
End With
wb.SaveAs "D:\" & k(ss) & ".xlsx" '将新建的工作簿保存在代码工作簿下
wb.Close True '关闭工作簿,并保存
Set wb = Nothing '释放内存
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "完成"
End Sub