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拆分后的结果。

vba 拆分工作簿并重命名工作表

随着Excel在办公自动化中的广泛应用，许多人开始学习VBA （Visual Basic for Applications）来简化重复性工作。

在实际工作中，经常需要将一个大的工作簿拆分成多个小的工作簿，并且需要对这些工作簿进行重命名。

本文将深入探讨如何使用VBA来实现这一需求。

1.拆分工作簿让我们来看看如何使用VBA来拆分一个大的工作簿。

我们可以通过创建一个宏来实现这一功能。

打开VBA编辑器，然后插入一个新的模块。

在模块中编写以下代码：```vbaSub SplitWorkbook()Dim ws As WorksheetApplication.ScreenUpdating = FalseFor Each ws In ThisWorkbook.Worksheetsws.CopyActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & & ".xlsx"ActiveWorkbook.Close FalseNext wsApplication.ScreenUpdating = TrueEnd Sub在这段VBA代码中，我们首先禁用屏幕更新，然后使用For Each循环遍历工作簿中的每个工作表。

对于每个工作表，我们将其复制到一个新的工作簿中，然后将新的工作簿另存为以工作表名命名的文件。

我们启用屏幕更新。

通过执行这段代码，我们可以将一个大的工作簿拆分成多个小的工作簿。

2.重命名工作表接下来，让我们来看看如何使用VBA来对工作表进行重命名。

同样，我们可以通过创建一个宏来实现这一功能。

在VBA编辑器中插入一个新的模块，然后编写以下代码：```vbaSub RenameWorksheets()Dim ws As WorksheetFor Each ws In ThisWorkbook.Worksheets = "New Name"Next wsEnd Sub```在这段VBA代码中，我们使用了For Each循环遍历工作簿中的每个工作表，并将其名称更改为“New Name”。

Excel高效办公VBA代码-快速将工作簿中的多张工作表拆分为工作簿

快速将工作簿中的多张工作表拆分为工作簿作者原著，尊重成果，侵权必究一、应用场景在处理数据中，经常碰到需要一个工作簿中的每张工作表，独立保存为一个工作簿。

单个复制，保存，耗时耗力。

利用vba代码将可以一键实现该功能，快速合并相同值的单元格。

二、示例1.要求：需要该工作簿的所有表格，单独保存为工作簿2.做法：利用vba 代码，实现一键拆分成多份工作簿，并保存三、重点：vba 源代码如下（具有通用性）Sub 拆分工作表()On Error Resume NextApplication.DisplayAlerts = False 需要这些工作表单独保存为各工作簿点击已集成的自定义宏按钮“拆分工作表”快速拆分拆分成4个工作簿If MsgBox("注意关闭其他Excel，选择取消关闭其他Excel", vbOKCancel) = vbOK ThenDim ph$, i!, a$, wk As WorkbookFor i = 1 To Sheets.Count Step 1Set wk = Workbooks.Adda = Workbooks(1).Sheets(i).nameWorkbooks(1).Sheets(i).Copy wk.Sheets(1)wk.Sheets(1).name = aph = Workbooks(1).Path & "\" & a & ".xlsx"wk.SaveAs phwk.CloseNextApplication.DisplayAlerts = TrueMsgBox "工作簿拆分完成！保存在原始Excel的文件夹内"Else: Exit SubEnd IfEnd Sub四、使用说明拆分的工作簿保存在原工作表所在的文件夹中；拆分时注意关闭无关的其他excel文件。

如何将vba代码以自定义宏的方式，集成到excel选项卡中，请自行百度学习。

利用VBA代码拆分数据到单个工作簿

工作需求将总表中的数据按行政区划拆分到一个个单独的工作簿中，且命名好工作簿。

源码VBA源码Sub 拆分记录到工作簿()Dim rng As Range, rct%, rngs As Range, titrng As RangeSet rng = [b2]Application.ScreenUpdating = FalseDorct = WorksheetFunction.CountIf([b2:b10000], rng.Value)Set rngs = rng(1, 0).Resize(rct,8)Set titrng = [a1:i1]Workbooks.Addtitrng.Copy [a1]rngs.Copy [a2]ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & rng.ValueActiveWorkbook.CloseSet rng = rng.Offset(rct, 0)Loop While rng <> ""Application.ScreenUpdating = TrueMsgBox ">>>处理完毕<<<"End SubVBA源码+注释注：前期工作，需要将第二列列数据处理成有规律的格式，见示例Sub 拆分记录到工作簿()注：宏名称为“拆分记录到工作簿”。

可以改。

Dim rng As Range, rct%, rngs As Range, titrng As Range注：定义变量，不用动。

Set rng = [b2]注：定义第一个要拆分出来的内容（示例为“北京”），需要处于B2单元格。

Application.ScreenUpdating = False注：关闭屏幕更新。

Dorct = WorksheetFunction.CountIf([b2:b10000], rng.Value)注：得到B2单元格内容有多少行。

VBA 中的工作簿合并与拆分技巧与实例

VBA 中的工作簿合并与拆分技巧与实例在日常的工作中，我们经常会处理多个Excel工作簿的数据，而VBA提供了强大的功能来帮助我们自动化这些任务。

本文将介绍VBA中的工作簿合并与拆分的技巧和实例，帮助您更高效地处理Excel数据。

一、工作簿合并技巧与实例在某些情况下，我们需要将多个工作簿中的数据合并到一个工作簿中。

以下是一些常用的VBA技巧和实例，可以帮助您完成这个任务。

1. 使用循环遍历工作簿首先，我们需要使用循环来遍历工作簿中的所有工作表，然后将它们复制到一个新的工作簿中。

以下是一个简单的示例代码：```vbaSub MergeWorkbooks()Dim ws As WorksheetDim wb As WorkbookDim mainWb As WorkbookSet mainWb = ThisWorkbook '将数据合并到当前工作簿 '遍历所有工作簿For Each wb In WorkbooksIf <> Then '排除当前工作簿 For Each ws In wb.Worksheetsws.Copyafter:=mainWb.Sheets(mainWb.Sheets.Count) '将工作表复制到主工作簿Next wsEnd IfNext wbEnd Sub```您可以根据需要修改代码中的变量来适应特定的情况。

这段代码将遍历所有打开的工作簿，并将它们的工作表复制到当前工作簿中。

2. 按条件合并工作表有时候我们只需要合并特定条件下的工作表，例如相同的供应商数据。

以下是一个示例代码：```vbaSub MergeWorksheets()Dim ws As WorksheetDim wb As WorkbookDim mainWb As WorkbookDim criteria As StringSet mainWb = ThisWorkbook '将数据合并到当前工作簿 criteria = "Supplier A" '合并供应商A的数据'遍历所有工作簿For Each wb In WorkbooksIf <> Then '排除当前工作簿For Each ws In wb.WorksheetsIf ws.Range("A1").Value = criteria Then '根据条件筛选工作表ws.Copyafter:=mainWb.Sheets(mainWb.Sheets.Count) '将工作表复制到主工作簿End IfNext wsEnd IfNext wbEnd Sub```您可以根据实际情况修改条件变量，以满足特定的需求。

vba-将工作簿中的各sheet拆分保存为新工作簿

Sub 自动拆分工作表到同一目录中()'' 自动拆分工作表宏'' 快捷键: Ctrl+m''把各个工作表以单独的工作簿文件保存在本工作簿所在的文件夹下的“拆分工作簿”文件夹下'获取活动工作簿所在路径并判断该路径下是否存在文件夹"拆分工作簿",如果不存在则创建'遍历活动工作簿中的每个工作表，复制并另存为新的工作簿，工作簿文件名以工作表名称命名'如果遇到隐藏工作表，则先打开隐藏，复制并另存为后关闭隐藏'Application.ScreenUpdating = False '关闭屏幕更新Dim xpath, isNext As StringDim sht As Worksheetxpath = Application.ActiveWorkbook.Path & "\拆分工作簿"If Len(Dir(xpath, vbDirectory)) = 0 Then MkDir xpath '如果文件夹不存在，则新建文件夹For Each sht In WorksheetsIf sht.Visible = False Then'MsgBox "有隐藏工作表" & '隐藏工作表是否拆分isNext = InputBox("1:跳过不处理" & Chr(10) & "2:处理并保持隐藏" & Chr(10) & "3:处理并取消隐藏" & Chr(10) & "空:不输入或其他值则默认不执行", "【" & & "】为隐藏工作表,请选择执行方式")If isNext = 2 Or isNext = 3 Thensht.Visible = True '取消工作表的隐藏sht.CopyActiveWorkbook.SaveAs Filename:=xpath & "\" & & ".xlsx"ActiveWorkbook.CloseIf isNext = 2 Thensht.Visible = False '恢复工作表的隐藏End IfEnd IfElseIf sht.Visible = True Thensht.CopyActiveWorkbook.SaveAs Filename:=xpath & "\" & & ".xlsx"ActiveWorkbook.CloseEnd IfNext'MsgBox "工作簿拆分结束"Application.ScreenUpdating = True '恢复屏幕更新End Sub。

excel拆分工作簿中的表为独立工作簿方法

excel拆分工作簿中的表为独立工作簿方法
【批量】拆分工作簿中的表为独立工作簿
工作当中经常会有人，把每个月或者每个部门的数据存放在同一个工作簿的新建工作表之中，之后又会遇到要把他们分开的需求，今天我们先来解决把工作簿中的工作表一键拆分成单个独立的工作簿的技巧吧！
正式介绍方法之前，我们先新建一个工作簿，其中存放有1班，2班，3班，4班，5班，六班等6张工作表，假定每张工作表上分别存放对应班级的人员期末考试成绩。

如下图所示：
原来的工作簿
制作过程
主要是运用成组工作表的功能。

操作如下：
打开VBE编辑器
粘贴如下所示代码：
Sub 拆分工作簿()
Dim i As Integer, s As Worksheet
Rem 忽略代码运行中的错误
On Error Resume Next
Rem 关闭屏幕刷新
Application.ScreenUpdating = False Rem 循环每一张工作表
For Each s In Worksheets
Rem 将工作表另存后关闭
s.Copy
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & & ‘.xlsx’
ActiveWorkbook.Close
Next
Rem 恢复屏幕刷新
Application.ScreenUpdating = True
End Sub
点击F5，就会在原工作簿所在的位置，生成所有的工作簿。

此代码是通用的哦！如果您喜欢就请点赞吧！。

利用VBA一次性取消隐藏所有表格，将工作簿所有表格拆分成独立文件

利⽤VBA⼀次性取消隐藏所有表格，将⼯作簿所有表格拆分成独⽴⽂件最近，⼗年先⽣收到⼩伙伴们咨询:1、如何⼀次性取消隐藏的所有⼯作表？2、如何把同个⼯作簿的所有表格拆分成独⽴⽂件？⼗年想说，尽管Excel为我们提供了很多好⽤的功能和函数，但还是有很多⼯作⽆法⽤现有功能和函数批量（第1个⽰例中，完成，⽐如上述的两个问题上述的两个问题。

但是，利⽤VBA语⾔编写的宏代码就能轻松实现这⼀点。

（）代码的使⽤⽅法）演⽰了VBA代码的使⽤⽅法取消所有⼯作表的隐藏、⼀次取消所有⼯作表的隐藏1、⼀次Excel可以⼀次隐藏多个⼯作表，但取消⼯作表隐藏却需要⼀个个的设置，⽤VBA编写⼀段代码，⼀秒搞定！注意要想使⽤VBA功能，需要把代码粘贴到添加的模块中，详见动画演⽰要想保存VBA代码，需要把⽂件另存为xlsm格式⽂件，详见动画演⽰动画演⽰：代码：Sub 取消隐藏()For x = 1 To Sheets.CountIf Sheets(x).Name <> '总表' ThenSheets(x).Visible = -1End IfNext xEnd SubSub 隐藏()For x = 1 To Sheets.CountIf Sheets(x).Name <> '总表' ThenSheets(x).Visible = 0End IfNext xEnd Sub2、拆分⼯作表为单独的excel⽂件把当前Excel⽂件中除第1个⼯作外的所有⼯作表，均保存为单独的excel⽂件到3⽉⽂件夹中。

拆分演⽰（在拆分过程中会画⾯会停⼏秒，请耐⼼等待）代码：Sub 拆分表格()Dim x As IntegerDim wb As WorkbookApplication.ScreenUpdating = FalseFor x = 2 To 32Sheets(x).CopySet wb = ActiveWorkbookWith wb.SaveAs ThisWorkbook.Path & '/3⽉/' & Sheets(x).Name & '.xlsx' .Close TrueEnd WithNext xApplication.ScreenUpdating = TrueEnd Sub。

【Excel VBA】批量将工作表转换为独立工作簿

【Excel VBA】批量将工作表转换为独立工作簿有时，我们需要将一个工作簿里的每一张工作表，另存为单独的工作薄；如果只是一两张工作表，我们手工操作就挺好的，可如果是若干张，手工操作……岂不是太……素颜？咳，美颜相机了解一下——如果使用VBA来处理，这事儿就简单了。

怎么个简单法呢？，请看动画视频：动画中所粘贴的代码如下：小贴士：由于代码取消了系统信息警告（Application.DisplayAlerts = False），当保存文件的路径下有重名工作簿时，该段代码会直接用新文件覆盖旧文件，不会发出提醒信息哦。

安，夜夜夜夜夜夜~Sub Newbooks()'EH技术论坛。

VBA编程学习与实践。

看见星光Dim sht As Worksheet, strPath$With Application.FileDialog(msoFileDialogFolderPicker) '选择保存工作薄的文件路径If .Show ThenstrPath = .SelectedItems(1)'读取选择的文件路径ElseExit Sub'如果没有选择保存路径，则退出程序End IfEnd WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"Application.DisplayAlerts = False'取消显示系统警告和消息，避免重名工作簿无法保存。

当有重名工作簿时，会直接覆盖保存。

Application.ScreenUpdating = False'取消屏幕刷新For Each sht In Worksheets'遍历工作表sht.Copy'复制工作表，工作表单纯复制后，会成为活动工作薄With ActiveWorkbook.SaveAs strPath & , xlWorkbookDefault '保存活动工作薄到指定路径下，以默认文件格式.Close True '关闭工作薄并保存End WithNextApplication.ScreenUpdating = True '恢复屏幕刷新Application.DisplayAlerts = True '恢复显示系统警告和消息MsgBox "处理完成。

使用VBA将Excel工作表分割成多个文件

使用VBA将Excel工作表分割成多个文件问题描述有一个表格，具体数据如下图所示。

这里需要按城市（即B列数据）对表格进行拆分，拆分出多个以城市名称命名的xlsx文件，每个xlsx文件都只包含当前城市的数据。

相关资料之前没有接触过Excel相关的编程，也没有学习过VB语言，完全是摸着石头过河。

在这里把期间使用过的一些资料罗列下，方便以后再次用到的时候，可以快速再捡起来。

1.Excel 2007 VBA Macro Programming2.这个是英文版的电子书，当初在皮皮书屋(皮皮书屋是好东西，你懂的)上随便找的，做为我VBA的入门书籍。

主要从这本书里学习了VBA的对象模型，几个常用的对象，Application、Workbook、Worksheet、Range。

这本书有个好的地方就是在书的后面有个索引，可以快速地查看自己想了解的内容。

这本书也有个大的缺陷，就是内容讲得还不够详细具体，往往找到了自己想了解的内容，想深入了解下各种操作，结果发现它讲完了。

3.在线教程4.这是个非常好的网站，里面包含了很多简单的例子及代码。

当想要实现某个简单地操作的时候，可以先到这里来找找看有没有相应的实例。

有一点搞不明白的就是，明明是中文网站，怎么贴的图片里的Excel都是日文的(好吧，不深究了)。

对于新手来说非常有用，推荐之。

5.Excel函数在线查询6.最权威的Excel函数查询网站，好吧，其实就是微软的MSDN 啦。

虽然说MSDN的文档有时候的确搞不清楚它在讲什么，但是它还是最详细的。

代码好吧，不废话了，直接上代码。

Sub XXX_Click()'输入用户想要拆分的工作表Dim sheet_namesheet_name = Application.InputBox("请输入拆分工作表的名称：")Worksheets(sheet_name).Select'输入获取拆分需要的条件列Dim col_namecol_name = Application.InputBox("请输入拆分依据的列号(如A):")'输入拆分的开始行，要求输入的是数字Dim start_row As Integerstart_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)'暂停屏幕更新Application.ScreenUpdating = False'工作表的总行数Dim end_rowend_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row'遍历计算所有拆分表，每个拆分表的格式为"表名称,表行数"'对于二维数组，ReDim只能扩充最后一维，因此sheet_map行不变，扩充列Dim sheet_map(), sheet_indexReDim sheet_map(1, 0)sheet_map(0, 0) = Range(col_name & start_row).Valuesheet_map(1, 0) = 1sheet_index = 0With Worksheets(sheet_name)Dim row_count, temp, irow_count = 0For i = start_row + 1 To end_rowtemp = Range(col_name & i).ValueIf temp = Range(col_name & (i - 1)).Value Thensheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1 ElseReDim Preserve sheet_map(1, sheet_index + 1)sheet_index = sheet_index + 1sheet_map(0, sheet_index) = tempsheet_map(1, sheet_index) = 1End IfNextEnd With'根据前面计算的拆分表，拆分成单个文件Dim row_indexrow_index = start_rowFor i = 0 To sheet_indexWorkbooks.Add'创建最终数据文件夹Dim dir_namedir_name = ThisWorkbook.Path & "\拆分出的表格\"If Dir(dir_name, vbDirectory) = "" ThenMkDir (dir_name)End If'创建新工作簿Dim workbook_pathworkbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xlsx"ActiveWorkbook.SaveAs workbook_path = sheet_map(0, i)'激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿ThisWorkbook.Activate'拷贝条目数据(即最前面不需要拆分的数据行)Dim row_rangerow_range = 1 & ":" & (start_row - 1)Worksheets(sheet_name).Rows(row_range).CopyWorkbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A1").PasteSpecial'拷贝拆分表的专属数据row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)Worksheets(sheet_name).Rows(row_range).CopyWorkbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A" & start_row).PasteSpecialrow_index = row_index + sheet_map(1, i)'保存文件Workbooks(sheet_map(0, i) & ".xlsx").Close SaveChanges:=TrueNext'进行屏幕更新Application.ScreenUpdating = TrueMsgBox "拆分工作表完成"End Sub似乎，博客的代码着色功能不是好呀，看着让人感觉好费力，再给大家上两张看着舒服的图片吧。