Excel-VBA把工作薄中的工作表拆分独立工作薄

合集下载

excel将一个工作表根据条件拆分成多个工作表，并将多个工作表怎么拆分成独立表格

excel将一个工作表根据条件拆分成多个工作表，并将多个工作表怎么拆分成独立表格目录一、原始数据表如下（sheet页名称为：数据源），需要根据B列人员所属组织拆分成每个组织一个工作表。

二、进入VBE编辑页面三、插入一个新的模块。

四、在模块1窗口粘入如下代码 ,并保存五、通过【开发者工具】，插入窗口按钮六、点击【按钮】，选择第一行，继续选择【组织】单元格即可七、在第四部粘贴代码进去后，直接点击运行也可以，按提示选择行和单元格，效果一样。

八、将多个sheet表拆分为独立表格一、原始数据表如下（sheet页名称为：数据源），需要根据B列人员所属组织拆分成每个组织一个工作表。

二、进入VBE编辑页面1.通过【开发工具】>>【查看代码】进入编辑页面2.通过【右击】sheet页名称，选择【查看代码】进入编辑页面3.通过ALT+F11进入编辑页三、插入一个新的模块。

四、在模块1窗口粘入如下代码 ,并保存1.Sub CFGZB()2.Dim myRange As Variant3.Dim myArray4.Dim titleRange As Range5.Dim title As Variant6.Dim columnNum As Integer7.myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)8.myArray = WorksheetFunction.Transpose(myRange)9.Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“组织”", Type:=8)10.title = titleRange.Value11.columnNum = titleRange.Column12.Application.ScreenUpdating = False13.Application.DisplayAlerts = False14.Dim i&, Myr&, Arr, num&15.Dim d, k16.For i = Sheets.Count To 1 Step -117.If Sheets(i).Name <> "数据源" Then18.19.End If20.Next i21.Set d = CreateObject("Scripting.Dictionary")22.Myr = Worksheets("数据源").UsedRange.Rows.Count23.Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))24.For i = 1 To UBound(Arr)25.d(Arr(i, 1)) = ""26.Next27.k = d.keys28.For i = 0 To UBound(k)29.Set conn = CreateObject("adodb.connection")30.conn.Open"provider=Microsoft.ACE.OLEDB.12.0;extended properties=Excel12.0;Data Source=" & ThisWorkbook.FullName31.Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"32.Worksheets.Add after:=Sheets(Sheets.Count)33.With ActiveSheet = k(i)35.For num = 1 To UBound(myArray)36..Cells(1, num) = myArray(num, 1)37.Next num38..Range("A2").CopyFromRecordsetconn.Execute(Sql)39.End With40.Sheets(1).Select41.Sheets(1).Cells.Select42.Selection.Copy43.Worksheets(Sheets.Count).Activate44.ActiveSheet.Cells.Select45.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False46.Application.CutCopyMode = False47.Next i48.conn.Close49.Set conn = Nothing50.Application.DisplayAlerts = True51.Application.ScreenUpdating = True52.End Sub五、通过【开发者工具】，插入窗口按钮六、点击【按钮】，选择第一行，继续选择【组织】单元格即可七、在第四部粘贴代码进去后，直接点击运行也可以，按提示选择行和单元格，效果一样。

VBA实例一、工作簿按表拆分成多个工作簿

VBA实例一、工作簿按表拆分成多个工作簿
大家好，本节主要介绍，通过VBA程序，将单个工作簿中的多个工作表，按表拆分成多个独立工作簿。

效果演示
一个工作簿中有多个工作表，将每个工作表拆分成独立的工作簿，生成的工作簿名称为原工作表名称，保存至原文件路径下，演示效果如下：
V B A 代码
思路是通过for each循环，将该工作簿中的每个表格对象赋值给sht变量，在循环中复制sht变量，将其另存为工作簿文件。

保存至原工作簿的路径下，工作簿的名称为原工作表的名称，另存完毕后关闭，最后msgbox弹窗提示完成。

为了提高代码效率，关闭屏幕更新。

代码如下：
Sub 拆分工作表()
'定义变量并赋值
Dim Sht As WorksheetDim MyBook As WorkbookSet MyBook = ThisWorkbook'关闭屏幕更新
Application.ScreenUpdating = False'通过for each循环工作表变量
For Each Sht In MyBook.Sheets Sht.Copy '另存到原文件路径下，名称为原工作表名称
ActiveWorkbook.SaveAs Filename:=MyBook.Path _ & '\' & , FileFormat:=xlNormal ActiveWorkbook.CloseNext'重新开启屏幕更新
Application.ScreenUpdating = True'弹窗提示
MsgBox '工作簿拆分完成'End Sub
Live and Learn。

Excel-VBA把工作薄中的工作表拆分独立工作薄

Excel-VBA把工作薄中的工作表拆分独立工作薄Excel-VBA把工作薄中的工作表拆分独立工作薄应用场景把工作薄的工作表拆分为独立的工作薄知识要点1：Application.FileDialog(msoFileDialogFolderPicker) 通过对话框选择存放路径2：Workbook.SaveAs 方法在另一不同文件中保存对工作簿所做的更改。

3：.Find('*]*'!' 查找工作表中是否存在外部引用，如有则转换为值4：Sheets.Copy(Before, After) 方法将工作表复制到工作簿的另一位置,如果既不指定Before 也不指定After，则将新建一个工作簿，其中包含复制的工作表。

5：Shell 函数执行一个可执行文件Shell 'EXPLORER.EXE' 用EXPLORER.EXE 打开文件夹6：explorer.exe是Windows程序管理器或者文件资源管理器，它用于管理Windows图形壳，包括桌面和文件管理Sub 把工作薄拆分为单个工作表() On Error Resume Next Dim Pathstr As String, i As Long, Activewb As String, Cell As Range, Firstaddress As String With Application.FileDialog(msoFileDialogFolderPicker) '创建文件对话框的实例If .Show Then '如果在对话框中单击了确定按钮Pathstr =.SelectedItems(1) '将选定的路径赋予变量ElseExit Sub End If End With Pathstr = Pathstr& IIf(Right(Pathstr, 1) = '\', '', '\') '如果不是\，末尾添加\ Application.ScreenUpdating = False Activewb = /doc/0c9588043.html'记录活动工作薄名For i = 1 To Sheets.Count '循环所有工作表Sheets(i).Copy '复制工作表到新工作薄中(忽略了参数) '将工作薄另存，文件名由工作表觉得，而文件的后缀名则由excel程序的版本决定ActiveWorkbook.SaveAs Filename:=Pathstr& Workbooks(Activewb).Sheets(i).Name &IIf(Application.Version * 1 < 12, '.xls', '.xlsx'),FileFormat:=xlWorkbookDefault, CreateBackup:=FalseWith /doc/0c9588043.htmledRange '引用已用区域'查找“=*]*'!”,也就是检查是否存在外部引用Set Cell = .Find('*]*'!', LookIn:=xlFormulas,searchorder:=xlByRows, lookat:=xlPart, MatchCase:=True) If Cell Is Nothing Then GoT o Line Firstaddress = Cell.Address '记录第一个找到的地址Do Cell = Cell.Value '将公式转换为数值Set Cell = .FindNext(Cell) '查找下一个IfCell Is Nothing Then Exit Do '如果未找到，退出循环If Cell.Address = Firstaddress Then Exit Do Loop End WithLine: ActiveWindow.Close '关闭窗口Workbooks(Activewb).Activate '激活待拆分的工作薄Next i Application.ScreenUpdating = True Shell'EXPLORER.EXE' & Pathstr, vbNormalFocus '打开文件夹End Sub。

Excel如何快速将工作簿中多个工作表拆分成独立文件

Excel如何快速将工作簿中多个工作表拆分成独立文件在Excel一个工作簿中有多个工作表，想把里面的每个工作表拆分出来，生成单独的文件保存起来，要怎么要操作呢？如果只有几个工作表还好，一个个保存，但是有几十个甚至上百个，一个个的保存可就太费劲了。

今天给你介绍用VBA的方法，秒将多个工作表变成独立文件。

操作步骤如下：1、打开文件，按下快捷键“Alt”+“F11”，打开VBA编辑器。

2、在VBA编辑器中，点击“插入”菜单，选择“模块”。

3、在新建的模块中，添加下面的宏代码：Sub SaveAllSheetsAsWorkbooks()Dim iDim sht As WorksheetApplication.DisplayAlerts = FalseFor Each sht In Sheetssht.Copyi = ThisWorkbook.Path & "\" & & ".xlsx"ActiveWorkbook.SaveAs iActiveWorkbook.CloseNextApplication.DisplayAlerts = TrueMsgBox "工作表拆分文件完成！", vbOKOnly, "提示"End Sub以上代码会遍历当前工作簿中的所有工作表，并逐个复制为新工作簿并进行保存。

注意：如果未开启宏，需要点击“文件”菜单，选择“选项”，进入Excel选项窗口，选择“信任中心”-“宏设置”，将“宏的安全性”选项设置为“启用所有宏”，才能执行以上代码。

4、在宏代码编辑窗口中，点击运行按钮（绿色小三角），即可执行宏代码，并依次保存所有工作表为单独的Excel文件。

EXCELVBA工作表拆分

EXCELVBA工作表拆分用VBA拆分工作表是一个不错的方法，特别是在处理大量数据的时候，能节省不少时间。

1、高级筛选：筛选并复制到新工作表的关键代码如下：Range("Database").AdvancedFilter _Action:=xlFilterCopy, _CriteriaRange:=Range("Criteria"), _CopyToRange:=Range("Paste"), _Unique:=False该代码执行结果是将Database区域的数据按照Criteria区域条件筛选，并粘贴到Paste区域。

AdvancedFilter(Action, [CriteriaRange], [CopyToRange], [Unique])是VBA中对Range对象进行筛选的方法：Action参数可以填xlFilterInPlace或xlFilterCopy，前者是直接进行筛选，后者是我们这次用到的筛选并复制功能；CriteriaRange是筛选条件的区域；CopyToRange是粘贴到的区域（如果Action参数为xlFilterInPlace 则不填）；Unique参数是布尔型，用来选择是否只保留一条重复记录。

这里需要详细说明的是CriteriaRange参数：筛选条件区域至少为两行，首行为列标题，与原记录中的列标题要一致。

同一行中，各列之间是AND逻辑不同行之间是OR逻辑如果标题行不一致或者出现空行，则全选因为CriteriaRange参数要求如此严格，所以我们在对表格数据进行筛选时会用两个临时单元格存放需要筛选的数据。

Sheet1.Range("ZZ2") = critTitleSheet1.Range("ZZ3") = critValue这里为了防止干扰已有数据，把临时数据放在了702列，从第2行开始是为了不影响UsedRange的使用。

excel工作表和工作簿拆分合并宏代码（亲测有效！）

excel工作表和工作簿拆分合并宏代码（亲测有效！）一、【宏代码】根据关键字将一个excel总表分成若干个单独分表的宏代码(即拆分)Sub SelectFile()With Application.Calculation = xlManual.MaxChange = 0.001End With'Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseCells.Delete Shift:=xlUpDim FileName As VariantFileName = Application.GetOpenFilename("Excel 文件(*.xls),*.xls", , "请选择要分表的工作表所在的位置！", , 0) If FileName = False Then Exit SubSet sjwk = Workbooks.Open(FileName) '要分表的数据所在表Set hzwk = ThisWorkbook '分表模版所在的表On Error Resume Nextvvv = Application.InputBox("请选要分表数据所在工作表关键字的第一个单元格" & Chr(13) & "注意1;用鼠标选择含关键字的第一个单元格,不要选标题行;2;若第一个单元格不可见，也可任选后，手工修改;3;新表会建在选择的数据表相同目录下,以关键字+文件名形式命名,有相同名字会自动覆盖！", , , , , , , 0)If vvv = False Then GoTo 100'以下是取得选择的工作表行列做标wz = InStr(1, vvv, "!")If wz > 0 Thenbname = Mid(vvv, 2, wz - 2) '工作表名If Left(bname, 1) = "'" Then bname = Mid(bname, 2, Len(bname) - 2)Elsebname = End Ifwz2 = InStr(1, vvv, "R")wz3 = InStr(1, vvv, "C")If wz2 > 0 And wz3 > 0 Thenhh = Val(Mid(vvv, wz2 + 1, wz3 - wz2 - 1)) '起始行ll = Val(Mid(vvv, wz3 + 1, Len(vvv) - wz3)) '选择的关键字所在列End IfIf wz2 > 0 And wz3 = 0 Thenhh = Val(Mid(vvv, wz2 + 1, Len(vvv) - wz2))ll = 0End IfIf wz2 = 0 And wz3 > 0 Thenhh = 0ll = Val(Mid(vvv, wz3 + 1, Len(vvv) - wz3))End Iflzm = Application.ConvertFormula(Formula:="=C" & ll, fromReferenceStyle:=xlR1C1, toReferenceStyle:=xlA1) '将R1C1样式变为A1样式lzm = Split(lzm, "$")(2) '将列数转为字母'以上是取得选择的工作表行列做标lastrow = edRange.Rows.Count '用已用区域,判断单元格是否为空的方法判断单列的最末行zhh = lastrowFor ttt = lastrow T o 1 Step -1If Range(lzm & ttt) <> "" Then Exit Forzhh = zhh - 1Nextzmh = zhh '用已用区域,判断单元格是否为空的方法判断单列的最末行'zmh = sjwk.Sheets(bname).Range(lzm & ":" & lzm).Find("*", , , , 1, 2).Row '最末行,此方法在有筛选时不能正确判断Application.StatusBar = "<工作簿:" & & " 工作表:" & bname & " 行号:" & hh & "-" & zmh & " 列字母:" & lzm & "> 正在处理,请等待....."'MsgBox ("表名:" & bname & "行号:" & hh & "列字母:" & lzm)Application.ScreenUpdating = Falsesjwk.Sheets(bname).Rows("1:" & hh - 1).Copy hzwk.Sheets("分表").Rows("1:" & hh - 1) '拷贝表头For ii = hh To zmhsjwk.Sheets(bname).Rows(ii).Copy hzwk.Sheets("分表").Rows(ii) '逐行拷贝所有明细,是因为原表可能有筛选或隐藏Nexthzwk.Sheets("分表").ActivateCells.EntireRow.Hidden = False '拷贝到"分表"后去除隐藏Dim WorkRange As RangeDim Cell As RangeSet WorkRange = Sheets("分表").UsedRange.SpecialCells(xlCellTypeFormulas) '查找有公式的单元格并将有"!"公式的转成值,也就是去除跨表引用的公式,保留本身公式For Each Cell In WorkRangeIf InStr(1, Cell.Formula, "!", 1) Then Cell.Value = Cell.ValueNext CellWith Application.Calculation = xlAutomatic.MaxChange = 0.001End With'以下通过字典取得关键字,通过逐个筛选关键字,分表为工作簿Dim dic, temp, arrDim rng As Range, sxq As RangeSet dic = CreateObject("scripting.dictionary") '字典'下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿Set rng = Range(lzm & hh & ":" & lzm & zmh)For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选If Not dic.exists(temp.Value) Thendic.Add temp.Value, ""End IfNextarr = dic.keys '返回此列不重复值的数组For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并删除不应有的内容hzwk.Sheets("分表").ActivateIf AutoFilterMode Then AutoFilterMode = False '工作表里有自动筛选则取消Set sxq = Range("a" & hh - 1 & ":" & lzm & zmh) '筛选区域sxq.AutoFilter ll, tempCells.CopyWorkbooks.Add '新建工作簿Workbooks(Workbooks.Count).Activate '激活新键工作簿ActiveSheet.PasteWorkbooks(Workbooks.Count).SaveAs FileName:=temp & "-" & '粘贴数据后将新工作簿保存为关键字+数据源表的名字Workbooks(Workbooks.Count).CloseNext temp100:sjwk.CloseCells.Delete Shift:=xlUp '两次清除"分表"中的数据,因为可能有筛选,一次清不完Cells.Delete Shift:=xlUpApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueApplication.StatusBar = FalseSet dic = Nothing'With Application' .Calculation = xlAutomatic'.MaxChange = 0.001' End WithMsgBox ("分表操作完毕,请到所选文件目录下查看!")End Sub二、【宏代码】多个工作簿合并到1个工作表（即合并）Sub 合并当前目录下所有工作簿的全部工作表()Dim MyPath, MyName, AWbNameDim Wb As Workbook, WbN As StringDim G As LongDim Num As LongDim BOX As StringApplication.ScreenUpdating = FalseMyPath = ActiveWorkbook.PathMyName = Dir(MyPath & "\" & "*.xls")AWbName = Num = 0Do While MyName <> ""If MyName <> AWbName ThenSet Wb = Workbooks.Open(MyPath & "\" & MyName)Num = Num + 1With Workbooks(1).ActiveSheet.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)For G = 1 To Sheets.CountWb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End (xlUp).Row + 1, 1)NextWbN = WbN & Chr(13) & Wb.Close FalseEnd WithEnd IfMyName = DirLoopRange("A1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & Num & "个工作薄下的全部工作表。

excel批量拆分工作表vba代码

Excel批量拆分工作表VBA 代码===================本代码将帮助您将一个包含多个工作表的Excel 文件拆分成多个单独的工作簿，每个工作簿包含原始工作表中的一个工作表。

以下是代码的详细步骤：1. 打开源文件和目标文件夹--------------------首先，您需要打开源文件和目标文件夹。

您可以使用`Workbooks.Open` 方法打开源文件，并使用`FSO` （文件系统对象）来访问目标文件夹。

```vba' 打开源文件Workbooks.Open "C:\path\to\source\file.xlsx"' 获取目标文件夹路径Dim targetFolder As StringtargetFolder = "C:\path\to\target\folder"2. 遍历源文件中的每个工作表----------------------接下来，您需要遍历源文件中的每个工作表。

您可以使用`Workbook.Sheets` 属性来获取所有工作表，并使用`For Each` 循环遍历每个工作表。

```vba' 遍历每个工作表Dim sheet As WorksheetFor Each sheet In ActiveWorkbook.Sheets```3. 将每个工作表中的数据复制到目标文件夹中的新建工作表中--------------------------------------------------------在遍历每个工作表后，您需要将当前工作表中的数据复制到目标文件夹中的新建工作表中。

您可以使用`Worksheet.Copy` 方法复制工作表，并将其保存到目标文件夹中。

```vba' 复制当前工作表并将其保存到目标文件夹中Dim targetWorkbook As WorkbookSet targetWorkbook = ActiveWorkbook.Sheets().Copy(After:=Sheets(Sheets.Cou nt))targetWorkbook.SaveAs targetFolder & "\" & & ".xlsx"```4. 根据需求对数据进行格式化和排版--------------------------您可以在复制工作表后对其进行格式化和排版。

Excel文件中利用VBA语句拆分工作簿

如下图所示，如何利用VBA语句将一个工作薄按照不同的归属单位拆分成多个工作簿并存盘。

Sub 保留表头拆分数据为若干新工作簿()Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%c = Application.InputBox("请输入拆分列号", , 6, , 1) '按A列划分输入1，依次类推If c = 0 Then Exit Sub '输入0则结束Application.ScreenUpdating = False '关闭屏幕闪烁Application.DisplayAlerts = False '关闭提示arr = [a1].CurrentRegion '选择区域lc = UBound(arr, 2) '最大下标Debug.Print (lc)Set rng = [a1].Resize(, lc) '定义第一行Set d = CreateObject("scripting.dictionary") '定义字典For i = 2 To UBound(arr) '循环If Not d.Exists(arr(i, c)) ThenSet d(arr(i, c)) = Cells(i, 1).Resize(1, lc)ElseSet d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc)) '合并End IfNextk = d.Keyst = d.itemsFor i = 0 To d.Count - 1With Workbooks.Add(xlWBATWorksheet)rng.Copy .Sheets(1).[a1]t(i).Copy .Sheets(1).[a2].SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls".CloseEnd WithNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "完毕" End Sub拆分后的结果。

1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。

Excel-VBA把工作薄中的工作表拆分独立工作薄
应用场景把工作薄的工作表拆分为独立的工作薄
知识要点
1：Application.FileDialog(msoFileDialogFolderPicker) 通过
对话框选择存放路径2：Workbook.SaveAs 方法在另一不
同文件中保存对工作簿所做的更改。

3：.Find('*]*'!' 查找工
作表中是否存在外部引用，如有则转换为值
4：Sheets.Copy(Before, After) 方法将工作表复制到工作簿
的另一位置,如果既不指定Before 也不指定After，则将新
建一个工作簿，其中包含复制的工作表。

5：Shell 函数执
行一个可执行文件Shell 'EXPLORER.EXE' 用EXPLORER.EXE 打开文件夹6：explorer.exe是Windows
程序管理器或者文件资源管理器，它用于管理Windows图
形壳，包括桌面和文件管理Sub 把工作薄拆分为单个工作
表() On Error Resume Next Dim Pathstr As String, i As Long, Activewb As String, Cell As Range, Firstaddress As String With
Application.FileDialog(msoFileDialogFolderPicker) '
创建文件对话框的实例If .Show Then '如果在对话框中单击了确定按钮Pathstr =
.SelectedItems(1) '将选定的路径赋予变量Else
Exit Sub End If End With Pathstr = Pathstr
& IIf(Right(Pathstr, 1) = '\', '', '\') '如果不是\，末尾添加\ Application.ScreenUpdating = False Activewb = '记录活动工作薄名For i = 1 To Sheets.Count '循环所有工作表Sheets(i).Copy '复制
工作表到新工作薄中(忽略了参数) '将工作薄另存，
文件名由工作表觉得，而文件的后缀名则由excel程序的版
本决定ActiveWorkbook.SaveAs Filename:=Pathstr
& Workbooks(Activewb).Sheets(i).Name &
IIf(Application.Version * 1 < 12, '.xls', '.xlsx'),
FileFormat:=xlWorkbookDefault, CreateBackup:=False
With edRange '引用已用区域'查
找“=*]*'!”,也就是检查是否存在外部引用Set Cell = .Find('*]*'!', LookIn:=xlFormulas,
searchorder:=xlByRows, lookat:=xlPart, MatchCase:=True) If Cell Is Nothing Then GoTo Line Firstaddress = Cell.Address '记录第一个找到的地址Do Cell = Cell.Value '将公式转换为数值
Set Cell = .FindNext(Cell) '查找下一个If
Cell Is Nothing Then Exit Do '如果未找到，退出循环
If Cell.Address = Firstaddress Then Exit Do Loop End WithLine: ActiveWindow.Close '关闭窗口
Workbooks(Activewb).Activate '激活待拆分的工作薄
Next i Application.ScreenUpdating = True Shell
'EXPLORER.EXE' & Pathstr, vbNormalFocus '打开文件夹End Sub。