excel将一个工作表根据条件拆分成多个工作簿（运行时代码错误）？
发布网友
共2个回答
热心网友
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
修改为：
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"
热心网友
驱动有问题。这个是比较老的版本了，一般是2003版以前可以用。
如果是按条件拆分的话可以试试用我的代码。
Public filepath As String
Public Sub 拆分表格()
Application.ScreenUpdating = False '关闭刷屏；
Dim asht As Worksheet '定义 asht
Dim shn As String '定义shn
Dim keys As Range
Dim keycol As Long, s As Long, EE As Long, x As Long '定
mrbm = ActiveSheet.Name
flag = InputBox("请选择拆分类型：" & Chr(10) & " 拆分到当前工作簿下各个子sheet，请输入1；" & Chr(10) & "拆分每一个到新的工作簿，请输入0 。", "请选择拆分类型")
If flag = 1 Then
filepath = ActiveWorkbook.Path
Else
With Application.FileDialog(msoFileDialogFolderPicker) '-------选择保存工作薄的文件路径
.AllowMultiSelect = False '-------不允许多选
If .Show Then filepath = .SelectedItems(1) Else Exit Sub
End With
End If
If Right(filepath, 1) <> "\" Then filepath = filepath & "\"
SourceData = Application.InputBox("一般情况下名字是【总表】或者【XX汇总表】，" & Chr(10) & "但是不绝对了，请根据实绩情况输入," & Chr(10) & "但是请不要输错哦", "请告诉我你想拆分哪个表格", mrbm, 1) '获取需要拆分的表格名字
If SourceData = "" Then Exit Sub
Set asht = Worksheets(SourceData) '获取表格名字赋给表格变量；
Set keys = Application.InputBox("请确认拆分时候需要按照哪个关键字段," & Chr(10) & "" & Chr(10) & "并选择这个字段所在的列。" & Chr(10), "请用鼠标选择拆分的关键列", Type:=8) '获取拆分关键字列
keycol = keys.Column
Call paixu(asht, keycol) '调用函数对关键字列排序,传递要排序的表格及关键行；
s = 2 '定义初始处理的行数为2，默认从第二行开始，首行为标题行；s为设定的行开始
With asht
For x = 2 To asht.Range("a1048576").End(xlUp).Row '建立循环，获取表的总行数；
If .Cells(x, keycol) <> .Cells(x + 1, keycol) Then '判定上下两行是否相同，
EE = x: shn = .Cells(s, keycol).Value ''不相同就将行数赋给 e变量；e为设定的行末尾；同时将关键字传递给新的表格名字；
If flag = 1 Then
Call copydatatonewsheet(asht, shn, s, EE)
Else
Call CopydatatonewWorkbook(asht, shn, s, EE) '抓到s,e后调用函数实现将首行及s到e行的数据复制到新生成的表格内；函数传递了源表，开始行S，结束行e，新的表格名字shn
End If
s = x + 1 '数据复制完成后，下一个循环的行首s赋值；
End If '结束if判定
Next x 'next 循环
End With
Application.ScreenUpdating = True '关闭刷屏；
End Sub
' 此函数实现将 asht表内的首行及 s，e行间的内容赋值到一个新的sheet shn内；
Private Function copydatatonewsheet(asht As Worksheet, shn As String, s As Long, EE As Long) '定义函数及变量
Sheets.Add after:=Worksheets(Worksheets.Count) '添加新表格到工作簿所有表格之后；
Worksheets(Worksheets.Count).Name = shn '添加的新表格命名为shn
Set newsht = Worksheets("" & shn & "") 'shn赋值给newsht
asht.Rows(1).Copy Destination:=newsht.Rows(1) '复制标题行
'asht.Rows("" & s & ":" & EE & "").Copy Destination:=newsht.Rows(2) '复制s：e行之间数据到新表；
asht.Rows(s & ":" & EE).Copy Destination:=newsht.Rows(2) '复制s：e行之间数据到新表；
End Function
' 此函数实现将 asht表内的首行及 s，e行间的内容赋值到一个新的workbook.sheet shn内；
Private Function CopydatatonewWorkbook(asht As Worksheet, shn As String, s As Long, EE As Long) '定义函数及变量
On Error Resume Next
Application.DisplayAlerts = False
Sheets.Add after:=Worksheets(Worksheets.Count) '添加新表格到工作簿所有表格之后；
Worksheets(Worksheets.Count).Name = shn '添加的新表格命名为shn
Set newsht = Worksheets("" & shn & "") 'shn赋值给newsht
asht.Rows(1).Copy Destination:=newsht.Rows(1) '复制标题行
'asht.Rows("" & s & ":" & EE & "").Copy Destination:=newsht.Rows(2) '复制s：e行之间数据到新表；
asht.Rows(s & ":" & EE).Copy Destination:=newsht.Rows(2) '复制s：e行之间数据到新表；
newsht.Move
ActiveWorkbook.SaveAs FileName:=filepath & shn & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Function
'此函数实现排序
Private Function paixu(tgtws As Worksheet, i As Long)
tgtws.Sort.SortFields.Clear '目标表格筛选取消
tgtws.Sort.SortFields.Add Key:=tgtws.Columns(i), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal '目标表格排序按照关键列 i
With tgtws.Sort
.SetRange tgtws.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Function
Private Sub getsheetname()
Dim iShtNm As String
Dim iSht As Worksheet
Do
Err.Clear
iShtNm = InputBox("请输入工作表名", "工作表名称")
If iShtNm = "" Then Exit Sub
On Error Resume Next
Set iSht = Sheets(iShtNm)
Loop While Err.Number <> 0
iSht.Activate
[a1].Select
MsgBox "ok"
End Sub追答如果想拆分的话，我有一个模板发来用一下。
