拆分的时候选择表头 和 A列分的
Sub fenbiao()
Dim myRange As Variant
Dim myArray
Dim titleRange As Range
Dim title As String
Dim s_name As String
'每次都要修改这个
s_name = "Sheet1"
Dim columnNum As Integer
myRange = Application.InputBox(prompt:="请选择标题行:", Type:=8)
myArray = WorksheetFunction.Transpose(myRange)
Set titleRange = Application.InputBox(prompt:="请选择拆分的表头,必须是第一行,且为一个单元格,如:“姓名”", Type:=8)
title = titleRange.Value
columnNum = titleRange.Column
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i&, Myr&, Arr, num&
Dim d, k
s_name = Sheets(1).Name
Set d = CreateObject("Scripting.Dictionary")
Myr = Worksheets(s_name).UsedRange.Rows.Count
Arr = Worksheets(s_name).Range(Cells(2, columnNum), Cells(Myr, columnNum))
For i = 1 To UBound(Arr)
d(Arr(i, 1)) = ""
Next
k = d.keys
For i = 0 To UBound(k)
Set conn = CreateObject("adodb.connection")
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
'下面最后的'' 如果是数字的话删除。
Sql = "select * from [" & s_name & "$] where " & title & " = '" & k(i) & "'"
sqlarr = conn.Execute(Sql)
Worksheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = k(i)
For num = 1 To UBound(myArray)
.Cells(1, num) = myArray(num, 1)
Next num
.Range("A2").CopyFromRecordset conn.Execute(Sql)
End With
Sheets(1).Select
Sheets(1).Cells.Select
Selection.Copy
Worksheets(Sheets.Count).Activate
ActiveSheet.Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next i
conn.Close
Set conn = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
再加个模块
Sub saveas()
Dim sht As Worksheet
Dim num As Integer
Dim MyBook As Workbook
Set MyBook = ActiveWorkbook
For Each sht In MyBook.Sheets
sht.Copy
If Right(MyBook.Name, 4) = "xlsx" Then
MsgBox "xlsx文件不能分表,建议另存xls后再处理"
num = 5
Else
num = 4
End If
ActiveWorkbook.saveas Filename:=MyBook.Path & "\" & Left(MyBook.Name, Len(MyBook.Name) - num) & "_" & sht.Name & Right(MyBook.Name, num), FileFormat:=xlNormal '将工作簿另存为EXCEL默认格式
ActiveWorkbook.Close
Next
MsgBox "文件已经被分拆完毕!"
End Sub