VBA工作薄工作表事件一览表修订稿

ExcelVBA解读（80）：看看工作表会自动响应哪些操作——认识工作表事件我们可以设置在工作表上进行操作时，工作表要做的事情，例如激活某工作表时弹出一个对话框、在单元格之间移动时高亮显示单元格所在的行列，等等。

这就要用到Worksheet对象的事件。

Worksheet对象的事件并不多，共9个，如图1所示。

图1其中，各个事件发生条件为：•Activate事件发生在工作表成为当前活动工作表时•BeforeDoubleClick事件发生在工作表单元格中双击时发生且在默认的双击操作之前•BeforeRightClick事件发生在工作表单元格中右击时发生且在默认的右击操作之前•Calculate事件发生在重新计算工作表后•Change事件发生在工作表单元格被修改后•Deactivate事件发生在转移到并使其他工作表为活动工作表前•FollowHyperlink事件发生在单击工作表中的超链接时•PivotTableUpdate事件发生在更新工作表中数据透视表后•SelectionChange事件发生在改变工作表单元格选择时下面分别详细介绍这些事件。

Activate事件Worksheet_Activate()在工作表成为活动工作表时触发该事件。

Deactivate事件Worksheet_Deactivate()当转移到其他工作表时触发该事件。

示例1：激活当前工作表与转移到其他工作表时的事件响应以工作表Sheet2为例，当激活使工作表Sheet2成为活动工作表时，以及转移到其他工作表时，分别显示相应的消息框。

Private Sub Worksheet_Activate()MsgBox 'Hi!欢迎来到【完美Excel】.', , 'excelperfect'End SubPrivate Sub Worksheet_Deactivate()MsgBox '谢谢你的来访!', , '完美Excel'End Sub代码效果如图2所示。

36 SheetPivotTableUpdate
数据透视表的工作表更新之后
37 SheetSelectionChange
工作表中选定区域改变时
38 SheetTableUpdate
当对工作表上的表进行更新时发生。
序号 1 2 3 4 5
6
7 8
9
10 11
12
13 14 15 16 17
39 Sync
40 WindowActivate 41 WindowDeactivate 42 WindowResize
该对象或成员已被弃用，但它仍保留为 对象模型的一部分以实现向后兼容。 在 新应用程序中，不应使用该对象或成员 工作薄的窗口激活时 工作薄的窗口变为非活动状态时 工作薄窗口调整大小时
事件 Activate BeforeDelete BeforeDoubleClick BeforeRightClick Calculate
9 BeforePrint
打印工作薄（或其中任何内容）之前
10 BeforeRemoteChange
在合并远程用户对工作簿的编辑之前发 生
11 BeforeSave
保存工作薄前
12 BeforeXmlExport
在 Microsoft Excel 保存或导出指定工 作簿中的 XML 数据之前发生此事件。
鼠标右键单击任一工作表时
26 SheetCalculate
工作表重新计算时
27 SheetChange
更改工作表中的单元格时
28 SheetDeactivate
任一工作表由活动状态转为非活动状态
29 SheetFollowHyperlink
单机Microsoft Excel中的任意超链接时

VBA 中的工作表和工作簿操作方法在 Excel 中，VBA（Visual Basic for Applications）是一种编程语言，可以用于自动化执行各种操作。

在VBA 中，工作表和工作簿是最常见的操作对象之一。

本文将介绍VBA 中的工作表和工作簿的基本操作方法，帮助您更好地利用 VBA 来进行数据分析和处理。

一、工作表的操作方法1. 打开工作表在 VBA 中，打开工作表的语法是：```Worksheets("工作表名称").Activate```其中，"工作表名称" 是您要打开的工作表的名称。

通过这种方式，您可以切换到特定的工作表。

2. 创建新工作表要在 VBA 中创建新的工作表，可以使用下面的语法：```Worksheets.Add```这将在活动工作簿中创建一个新的工作表。

您可以根据需要使用 VBA 代码自动创建新的工作表。

3. 删除工作表要删除工作表，可以使用下面的语法：```Worksheets("工作表名称").Delete```这将删除指定名称的工作表。

请注意，删除工作表操作是不可撤销的，因此在执行删除操作之前要确保操作的准确性。

4. 重命名工作表要重命名工作表，可以使用下面的语法：```Worksheets("旧工作表名称").Name = "新工作表名称"```这将把旧工作表名称修改为新的工作表名称。

通过这种方式，您可以方便地更改工作表的名称。

5. 循环访问工作表在 VBA 中，您可以使用循环语句来访问工作簿中的多个工作表。

以下是一个示例，演示如何使用 For Each 循环访问所有工作表并执行相同的操作：```For Each ws In Worksheets' 您的代码逻辑Next ws```通过这种方式，您可以逐个访问工作簿中的每个工作表，并在代码逻辑中执行相应的操作。

不同工作薄汇总VBA代码以下是一个用于将不同工作簿数据汇总的VBA代码示例，代码注释中有详细说明每一行代码的作用：```vbaSub 汇总不同工作簿数据Dim SummarySheet As Worksheet ' 汇总数据的工作表Set SummarySheet = ThisWorkbook.Sheets("汇总") ' 设置汇总数据的工作表名称Dim SourceFolder As String ' 存储源文件夹路径SourceFolder = "C:\SourceFolder" ' 设置源文件夹路径Dim FileExtension As String ' 存储文件扩展名FileExtension = "*.xlsx" ' 设置文件扩展名Dim FileName As String ' 存储文件名FileName = Dir(SourceFolder & "\" & FileExtension) ' 获取第一个文件Dim LastRow As Long ' 存储汇总数据的最后一行LastRow = SummarySheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' 获取汇总数据的最后一行Application.ScreenUpdating = False ' 关闭屏幕更新，加快代码执行速度Do While FileName <> "" ' 循环直到没有文件为止Dim SourceWorkbook As Workbook ' 存储源工作簿Set SourceWorkbook = Workbooks.Open(SourceFolder & "\" & FileName) ' 打开源工作簿Dim SourceSheet As Worksheet ' 存储源工作表Set SourceSheet = SourceWorkbook.Sheets("数据") ' 设置源工作表名称Dim LastRowSource As Long ' 存储源数据的最后一行LastRowSource = SourceSheet.Cells(Rows.Count,1).End(xlUp).Row ' 获取源数据的最后一行Dim SourceRange As Range ' 存储源数据的范围Set SourceRange = SourceSheet.Range("A2:G" & LastRowSource) ' 设置源数据的范围SourceRange.Copy SummarySheet.Cells(LastRow, 1) ' 将源数据复制到汇总数据的下一行SourceWorkbook.Close SaveChanges:=False ' 关闭源工作簿LastRow = SummarySheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' 更新汇总数据的最后一行FileName = Dir ' 获取下一个文件LoopApplication.ScreenUpdating = True ' 打开屏幕更新End Sub```这段代码假设要将位于文件夹路径`C:\SourceFolder`中名为`数据.xlsx`的工作簿的"数据"工作表数据汇总到当前工作簿的"汇总"工作表中。

ExcelVBA工作薄5.11批量保护工作薄我的数据不是你能改动的前景提要经过了几天不断地分享之后，关于工作薄的汇总和合计的相关操作，就告一段落了，后面还有需要或者还有新的想法再写出来分享给大家今天我们重新回到计划中来，我们今天要分享一些工作薄的保护功能，说到工作薄的保护大家都会想到是工作薄的打开的密码，就是这里单独一个工作薄的加密是非常的简单的，在excel中手工操作几个按钮既可以，但是如果批量的呢？就不是几个按钮的问题了，所以需要呼叫VBA了。

场景模拟我们还是用昨天的数据模型，假设我们成功的完成了每个地区的销售数据的统计，我们现在需要将自己汇总好的这份数据交给他的人使用，因为其他的部门的人也需要这份数据来作为参考分析，但是你汇总之后的数据你并不希望他们随意的乱改，至少原始数据是不能够被修改的，所以我们要给所有的原始数据加一个保护功能，上代码代码区•••••••••••••••Sub protect()Dim pathn$pathn = ThisWorkbook.Pathf = Dir(pathn & "\")Do While f <> "" If f <> "test.xlsm" Then Application.ScreenUpdating = False Workbooks.Open (pathn & "\" & f) ActiveSheet.protect "123" Application.ScreenUpdating = True ActiveWorkbook.Close True End If f = Dir()Loop End Sub 我们来看看最终的效果文件可以正常打开并复制粘贴但是如果如果你想要修改数据，对不起，警告想要修改保护模式，密码只有我知道，你完全没有办法撤销这样就实现了简单的工作薄的保护功能了，当然这样的功能并不是最好的，因为还是可以增加工作表等其他的操作，并不算是最佳的保护方式，等后面全部学习完了，我再分享一些比较霸道的保护工作薄数据的方式，我们还是学习为主，今天先学习下简单的数据保护功能代码分析很简单，保护的功能就一句代码•ActiveSheet.protect "123"记住，直接套用，收工！。

B
1.2 用户自定义函数
1 Excel VBA基础
1.3 Excel对象模型
https:///
1.3.1 对 象
1.3.2 获 取帮助
1.3.3 在 立即窗口
里试验
1.4.1 基本的输入和输出 1.4.3 括号和参数列表
1.4.5 变量的作用域和生存 期
1 Excel VBA基础
6 数据列表
6 数据列表
A
6.1 结构 化数据
D
6.4 排 序表
B
6.2 排序 单元格区
域
E
6.5 自 动筛选
C
6.3 创 建表
F
6.6 高 级筛选
6 数据列表
01
6.7 数 据记录
单
02
6.8 小 结
6 数据列表
06
6.5.6 获取 准确的日期
05
6.5.5 日期
格式问题
04
6.5.4 添加
3.1.3 覆盖 现有的工作 簿
3.1.2 在相 同目录中的 文件
3.1.4 保存 改变
3 工作簿和工作表
3.2.1 工作表
3.2.2 复制和 移动
3.2.3 组合工 作表
3.2 Sheets集合
06
Part One
4 使用单元格区域
4 使用单元格区域
4.1 Activate 和Select
4.2 Range属 性
PivotChart
03
7.3
PivotItems
02
7.2
PivotField
01
7.1 创建数据
透视表报表
7 数据透视表
7.1.1 PivotCach e

VBA图表操作技巧分享图表是数据可视化的重要工具之一，在Excel中使用VBA可以方便地对图表进行操作和修改。

本文将分享一些VBA图表操作的技巧，帮助您更好地处理和呈现数据。

1. 创建和修改图表在VBA中，您可以使用Chart对象来创建和修改图表。

首先，您需要确认要操作的图表所在的工作表。

以下是创建和修改图表的一些常用方法：- 创建图表：使用Charts.Add方法可以在指定位置添加一个新的图表。

例如，可以使用下面的代码在Sheet1中创建一个柱状图：```Charts.AddActiveChart.SetSourceData Source:=Sheets("Sheet1").Range("A1:B10")ActiveChart.ChartType = xlColumnClustered```- 修改图表类型：使用ChartType属性可以修改图表类型。

例如，将上面的柱状图修改为折线图：```ActiveChart.ChartType = xlLine```- 修改图表数据范围：使用SetSourceData方法可以修改图表的数据范围。

ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range("A1:C10")```- 修改图表标题：使用ChartTitle属性可以修改图表的标题。

```ActiveChart.ChartTitle.Text = "Sales data"```2. 调整图表元素除了修改图表本身的属性外，您还可以使用VBA来调整图表的元素，例如图例、数据标签和坐标轴。

以下是一些常用方法：- 图例位置：使用Legend.Position属性可以设置图例的位置。

例如，将图例位置设置为左侧：```ActiveChart.Legend.Position = xlLegendPositionLeft```- 数据标签：可以使用DataLabels属性来显示数据标签。

VBA开发中的工作簿与工作表操作VBA（Visual Basic for Applications）是一种从微软开发的用于自动化任务的编程语言。

在Excel等Microsoft Office软件中，VBA能够帮助用户完成许多重复性的工作，提高工作效率。

在VBA开发中，对工作簿和工作表的操作是非常常见的任务。

本文将详细介绍如何在VBA 中对工作簿和工作表进行操作。

首先，我们需要了解工作簿（Workbook）和工作表（Worksheet）的概念。

工作簿是Excel文件的容器，可以包含一个或多个工作表。

而工作表则是Excel文件中的一个分页，用于存储和管理数据。

一、工作簿操作1. 创建和保存工作簿在VBA中，我们可以使用`Workbooks.Add`方法来创建一个新的工作簿，并使用`Workbook.SaveAs`方法将其保存到指定的路径。

以下是一个示例：```Sub CreateAndSaveWorkbook()Dim wb As WorkbookSet wb = Workbooks.Addwb.SaveAs "C:\Path\To\Workbook.xlsx"End Sub```2. 打开和关闭工作簿使用`Workbooks.Open`方法可以打开一个已存在的工作簿，使用`Workbook.Close`方法可以关闭当前工作簿并保存更改。

以下是一个示例：```Sub OpenAndCloseWorkbook()Dim wb As WorkbookSet wb = Workbooks.Open("C:\Path\To\Workbook.xlsx")' 在这里进行其他操作wb.Close SaveChanges:=TrueEnd Sub```3. 切换工作簿VBA中的`Workbooks`对象表示当前打开的所有工作簿集合。

使用`Workbook.Activate`方法可以激活一个工作簿，使其成为当前正在操作的工作簿。

帶你入門VBA，第四講（如何控制關於工作薄與工作表）大家好!今天主要是研究一下在VBA中怎樣控制工作薄和工作表，其實就是要熟悉和掌握工作薄和工作表的一些常用屬性和方法及事件。

工作薄即是我們常說的一個EXCEL檔，可以把它比喻成一本書(Workbook)而工作表呢，就是書中的每一頁(sheet)。

請有興趣參加的朋友新建一個工作薄,命名為"1",保存到桌面上.並在SHEET1工作表中從表單中添加一個按紐.添加表單後,在自動彈出的指定宏對話方塊中點擊新建,就進入了VBE編輯器此主題相關圖片如下：在下面兩句中間輸入Workbooks後再輸入個點("."),就會出現一個下拉清單,框中的帶小手指的就是工作薄集合的屬性,帶飛行的小書本的是方法,比如:新建(ADD),關閉(CLOSE),打開(OPEN)就是方法Sub 按紐1_單擊()Workbooks. End Sub此主題相關圖片如下：在下拉清單中選取ADD即：Workbooks.Add運行程式詴詴看會出現什麼情況？以下是引用happy91在2004-10-14 10:35:00的發言：open不能選，提示錯誤可以選，但要指出路徑和檔案名把原來的代碼刪除掉，輸入Workbooks.Count這是統計打開工作薄的數量如果你對某個方法或屬性不懂，選取該屬性或方法後按F1，即可看到該方法或屬性的幫助說明而OPEN屬性則是打開工作薄比如：workbooks.open filename:="c:\2.xls"以下是引用happy91在2004-10-14 10:59:00的發言：我想設為只應用于本工作薄，在哪設（不在程式中設），因為我同時要打開別的工作薄工作詳細些.指定工作薄:Workbooks("工作薄名稱")以下是引用先鋒在2004-10-14 11:01:00的發言：運行結果COUNT的屬性使用無效，要不要賦一個變數，變數=物件.屬性改成下麵的:Sub 按鈕1_單擊() MsgBox Workbooks.Count End Sub 注:Workbooks中的"S"別少了把打開的某個工作設為當前工作薄Workbooks("2.XLS").Activate以下是引用求奇在2004-10-14 11:08:00的發言：輸入WORKBOOKS.COUNT後運行出現錯誤。

VBA编写Excel事件处理程序在Excel中，VBA（Visual Basic for Applications）是一种强大的编程语言，可以帮助用户自动化并加快他们的工作流程。

其中，事件处理程序是一种重要的VBA编程技术，可以让用户在特定事件发生时执行特定的操作。

下面将介绍如何编写Excel事件处理程序，以便更好地利用VBA的功能。

首先，要在Excel中编写事件处理程序，需要打开Excel并按下Alt + F11打开VBA编辑器。

然后，在VBA编辑器中，选择“插入”菜单下的“模块”，在新建的模块中编写VBA代码。

事件处理程序是基于Excel中的事件触发的，比如单元格内容改变、工作表激活等。

下面以一个示例来说明如何编写一个简单的事件处理程序。

假设我们要在单元格A1中输入内容后，自动在单元格B1中显示相同的内容。

首先，需要在VBA编辑器中插入以下代码：```vbaPrivate Sub Worksheet_Change(ByVal Target As Range)If Not Intersect(Target, Me.Range("A1")) Is Nothing ThenApplication.EnableEvents = FalseMe.Range("B1").Value = Target.ValueApplication.EnableEvents = TrueEnd IfEnd Sub```在上面的代码中，Worksheet_Change是一个工作表事件，代表当工作表中的单元格内容发生改变时触发的事件。

当目标单元格是A1并且内容改变时，会将A1的内容自动复制到B1中。

需要注意的是，在赋值时要将Application.EnableEvents设为False，防止死循环。

当然，事件处理程序不止局限于Worksheet_Change事件，还有其他一些常用的事件，比如工作表激活事件、工作表关闭事件等。

ExcelVBA解读（81）：工作表事件示例本文再列举一些示例，以加深对工作表事件的理解，方便应用。

示例1：阻止用户修改指定单元格区域的数据当用户修改工作表中指定单元格区域的数据时，给出提示信息并改回为原数据。

代码如下：Dim dataPrivate Sub Worksheet_Change(ByValTarget As Range)If Not Intersect(Target, Range('A1:C3')) Is Nothing ThenMsgBox '该区域数据重要,请不要修改!'Application.EnableEvents = FalseTarget.Value = dataApplication.EnableEvents = TrueEnd IfEnd SubPrivate Sub Worksheet_SelectionChange(ByValTarget As Range)data = Target.ValueEnd Sub运行效果如图1所示。

图1示例2：让不同的工作表有不同的快捷菜单在工作表“完美Excel”中，单击右键会出现属于该工作表的快捷菜单，同样，在工作表“Data”中单击右键也会出现属于该工作表的快捷菜单。

如下图2所示。

图2实现上述效果的代码如下。

在“完美Excel”工作表代码模块的BeforeRightClick事件中，输入下面的代码：Private SubWorksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)Dim cmb_excelperfect As CommandBarSet cmb_excelperfect = CreateSubMenu('完美Excel')Cancel = Truecmb_excelperfect.ShowPopupEnd Sub在“Data”工作表代码模块的BeforeRightClick事件中，输入相似的代码：Private SubWorksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)Dim cmb_data As CommandBarSet cmb_data = CreateSubMenu('数据处理')Cancel = Truecmb_data.ShowPopupEnd Sub插入一个标准模块，并输入下面的代码：示例3：双击单元格时显示输入框在双击工作表第1列中的单元格时，会显示下图3所示的自定义输入框。

1，多工作表汇总（Consolidate）‘.excelpx./dispbbs.asp?boardID=5&ID=110630&page=1‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。

Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorksheetDim sht As WorksheetDim WbCount As IntegerSet bk = Sheets("汇总")WbCount = Sheets.CountReDim RangeArray(1 To WbCount - 1)For Each sht In SheetsIf <> "汇总" Theni = i + 1RangeArray(i) = "'" & & "'!" & _sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1) End IfNextbk.Range("A1").Consolidate RangeArray, xlSum, True, True[a1].Value = ""End SubSub sumdemo()Dim arr As Variantarr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6") With Worksheets("汇总").Range("A1").Consolidate arr, xlSum, True, True.Value = ""End WithEnd Sub2，多工作簿汇总（Consolidate）‘多工作簿汇总Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorkbookDim sht As WorksheetDim WbCount As IntegerWbCount = Workbooks.CountReDim RangeArray(1 To WbCount - 1)For Each bk In Workbooks '在所有工作簿中循环If Not bk Is ThisWorkbook Then '非代码所在工作簿Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表i = i + 1RangeArray(i) = "'[" & & "]" & & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1) End IfNextWorksheets(1).Range("A1").Consolidate _RangeArray, xlSum, True, TrueEnd Sub3，多工作簿汇总（FileSearch）‘/thread-442007-1-1.html###‘help\汇总表.xlsSub pldrwb0531()'汇总表.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookm = [a65536].End(xlUp).Rowarr = Range(Cells(3, 3), Cells(m, 3))Sht1.Activatecol1 = col1 + 1Cells(2, col1) = nm '自动获取文件名Cells(3, col1).Resize(UBound(arr), 1) = arrwb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$Sub pldrwb0531()'汇总表.xls'导入指定文件的数据（默认工作表1的数据）'直接从C列依次导入Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetss = s & & ","Nexts = Left(s, Len(s) - 1)ar = Split(s, ",")UserForm1.ShowFor j = 0 To UBound(ar1)If Err.Number = 9 Then GoTo 100Set sh = wb.Sheets(ar1(j))sh.Activatem = sh.[a65536].End(xlUp).Rowarr = Range(Cells(3, 3), Cells(m, 3))Sht1.Activatecol1 = col1 + 1Cells(2, col1) = sh.[a1]Cells(3, col1).FormulaR1C1 = "=[" & nm & "]" & ar1(j) & "!RC3" ‘显示引用的工作簿工作表及单元格地址Cells(3, col1).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1))‘Cells(3, col1).Resize(UBound(arr), 1) = arrNext j100: wb.Close savechanges:=FalseSet wb = Nothings = ""If VarType(ar1) = 8200 Then Erase ar1End IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubPrivate Sub CommandButton1_Click()For i = 0 To ListBox1.ListCount - 1If ListBox1.Selected(i) = True Thens = s & ListBox1.List(i) & ","End IfNext iIf s <> "" Thens = Left(s, Len(s) - 1)ar1 = Split(s, ",")MsgBox "你选择了 " & sUnload UserForm1Elsemg = MsgBox("你没有选择任何工作表！需要重新选择吗？ ", vbYesNo, "提示") If mg = 6 ThenElseUnload UserForm1End IfEnd IfEnd SubPrivate Sub CommandButton2_Click()Unload UserForm1End SubPrivate Sub UserForm_Initialize()With Me.ListBox1.List = ar ‘文本框赋值.ListStyle = 1 ‘文本前加选择小方框.MultiSelect = 1 ‘设置可多选End Withbel1.Caption = bel1.Caption & nmEnd Sub4，多工作表汇总（字典、数组）‘/viewthread.php?tid=450709&pid=2928374&page=1&extra=page%3D 1‘Data多表汇总0623.xlsSub dbhz()'多表汇总Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht As WorksheetDim d, k, t, Myr&, Arr, xApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet d = CreateObject("Scripting.Dictionary")For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字If InStr(, "-") > 0 Then Sht.Delete: GoTo 100nm = Mid(Sht.[a3], 7)d(nm) = ""100:Next ShtApplication.DisplayAlerts = Truek = d.keysFor i = 0 To UBound(k)Sheets.Add after:=Sheets(Sheets.Count)Set Sht1 = ActiveSheet = Replace(k(i), "/", "-") ‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“Next iErase kSet d = NothingFor Each Sht In SheetsWith Sht.ActivateIf InStr(.Name, "-") = 0 Thennm = Replace(Mid(.[a3], 7), "/", "-")Myr = .[h65536].End(xlUp).RowArr = .Range("d10:h" & Myr)Set d = CreateObject("Scripting.Dictionary")For i = 1 To UBound(Arr)x = Arr(i, 1)If Not d.exists(x) Thend.Add x, Arr(i, 5)Elsed(x) = d(x) + Arr(i, 5)End IfNextk = d.keyst = d.itemsSet Sht2 = Sheets(nm)Sht2.Activatemyr2 = [a65536].End(xlUp).Row + 1If myr2 < 9 ThenCells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")Cells(10, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k) Cells(10, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) ElseCells(myr2, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k) Cells(myr2, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) End IfErase kErase tSet d = NothingEnd IfEnd WithNext ShtApplication.ScreenUpdating = TrueEnd Sub5，多工作簿提取指定数据（FileSearch）‘2011-8-31‘/thread-759188-1-1.htmlSub GetData()Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)Dim myFs As FileSearch, myfileDim myPath As String, Filename$, wbnm$Dim i&, n&, mm&, aa$, nm1$, j&Dim Sht1 As Worksheet, sh As Worksheet, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb1 = ThisWorkbookwbnm = Left(, Len() - 4)Set Sht1 = ActiveSheetSht1.[a2:w200] = ""aa = Left(, 2)Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\"With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)nm1 = Split(Mid(Filename, InStrRev(Filename, "\") + 1), ".")(0) If nm1 = wbnm Then GoTo 200Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsIf InStr(, aa) Thensh.ActivateIf aa = "班子" Thenmm = mm + 1Brrbz(mm, 1) = [b2].ValueFor j = 2 To 18 Step 2If j < 10 ThenBrrbz(mm, j) = Cells(j / 2 + 34, 11).Value ElseBrrbz(mm, j) = Cells(j / 2 + 34, 9).Value End IfNextGoTo 100ElseIf [b2] = "" Then GoTo 50mm = mm + 1Brrgr(mm, 1) = [b2].ValueBrrgr(mm, 2) = [e38].ValueBrrgr(mm, 3) = [i38].ValueFor j = 4 To 18 Step 2If j < 12 ThenBrrgr(mm, j) = Cells(j / 2 + 38, 8).ValueElseBrrgr(mm, j) = Cells(j / 2 + 38, 7).Value End IfNextFor j = 20 To 23Brrgr(mm, j) = Cells(j + 28, 8).ValueNextEnd IfEnd If50:Next100:wb.Close savechanges:=FalseSet wb = Nothing200:NextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithIf aa = "班子" Then[a2].Resize(mm, 19) = BrrbzElse[a2].Resize(mm, 23) = BrrgrEnd If[a1].SelectSet myFs = NothingEnd Sub‘2011-7-15‘/viewthread.php?tid=741341&pid=5036524&page=1&extra= Sub pldrsj()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, BrrDim myPath$, Filename$, nm2$Dim i&, j&, n&, aa$, nm$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetSht1.Cells.ClearContentsnm2 = Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim Brr(1 To n, 1 To 2)ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名If nm <> nm2 Thenj = j + 1Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.Sheets("Sheet1")Brr(j, 1) = nmBrr(j, 2) = sh.[c3].Valuewb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[a3].Resize(UBound(Brr), 2) = BrrSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubSub pldrsj0707()'/thread-456387-1-1.html'Report 2.xls'批量导入指定文件的数据Dim myFs As FileSearch, myfileDim myPath As String, Filename$, ma&, mc&Dim i As Long, n As Long, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheet: nn = 5Sht1.[b5:e27] = ""Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\data" ‘指定的子文件夹搜索With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)nm1=split(mid(filename,instrrev(filename,"\")+1),".")(0) 一句代码代替以下3句‘aa = InStrRev(Filename, "\")‘nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel 文件名‘nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名If nm1 <> ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetssh.Activatema = [b65536].End(xlUp).RowIf ma > 6 Then ‘第6行是表头If ma > 10 Then ma = 10 ‘只要取4行数据For ii = 7 To maSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 6).Value nn = nn + 1Next iiGoTo 100ElseGoTo 100End Ifmc = [d65536].End(xlUp).RowIf mc > 7 Then ‘第7行是表头If mc > 11 Then mc = 11 ‘只要取4行数据For ii = 8 To mcSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 8).Value nn = nn + 1Next iiGoTo 100ElseGoTo 100End If100:Next shwb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=462710&pid=3020658&page=1&extra=page%3D 2‘sum.xlsSub pldrsj0724()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, Myr1&, ArrDim myPath$, Filename$, nm2$Dim i&, j&, n&, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetMyr1 = Sht1.[a65536].End(xlUp).RowArr = Sht1.Range("a3:b" & Myr1)Sht1.Range("b3:b" & Myr1).ClearContentsnm2 = Left(, Len() - 4)Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名If nm1 <> nm2 ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsFor j = 1 To UBound(Arr)If = Arr(j, 1) Thensh.ActivateSet r1 = Range("c:c").Find()nn = r1.RowArr(j, 2) = Cells(nn, 9)GoTo 100End IfNext jNext sh100:wb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[b3].Resize(UBound(Arr), 1) = Application.Index(Arr, 0, 2)Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub6，多工作表提取指定数据（数组）‘excel.aa.topzj./viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718 Sub fpkf()Application.ScreenUpdating = FalseDim Myr&, Arr, yf, x&, Myr1&, r1Dim Sht As WorksheetMyr = Sheet1.[b65536].End(xlUp).RowSheet1.Range("c8:h" & Myr).ClearContentsArr = Sheet1.Range("c8:h" & Myr)[j8].Formula = "=rc[-9]&""|""&rc[-8]"[j8].AutoFill Range("j8:j" & Myr)Range("j8:j" & Myr) = Range("j8:j" & Myr).ValueFor Each Sht In SheetsIf <> Thenyf = Left(, Len() - 2)Sht.ActivateMyr1 = [a65536].End(xlUp).Row - 1For x = 7 To Myr1If Cells(x, 1) <> "" ThenSet r1 = Sheet1.Range("j:j").Find(Cells(x, 1) & "|" & Cells(x, 2)) If Not r1 Is Nothing ThenArr(r1.Row - 7, yf) = Cells(x, "ar")End IfEnd IfNext xEnd IfNextSheet1.Activate[c8].Resize(UBound(Arr), UBound(Arr, 2)) = Arr[j:j].ClearApplication.ScreenUpdating = TrueEnd Sub7，多工作簿多工作表查询汇总去重复值（字典数组）‘/viewthread.php?tid=485193&pid=3181286&page=1&extra=page%3D 1‘详细记录.xls‘3个工作簿需要都打开Sub xxjl()Dim Sht1 As Worksheet, Sht As WorksheetDim wb1 As Workbook, wb2 As Workbook, wb3 As WorkbookDim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$Application.ScreenUpdating = FalseSet wb1 = ActiveWorkbookSet wb2 = Workbooks("购进")Set wb3 = Workbooks("配料")wb2.ActivateMyr2 = [a65536].End(xlUp).RowArr2 = Range("a2:d" & Myr2)wb3.ActivateFor i = 1 To UBound(Arr2)wb3.Activatexm = Arr2(i, 2)For Each Sht In SheetsIf = xm ThenSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a1:b" & Myr)For j = 1 To UBound(Arr)yl = Arr(j, 1)wb1.ActivateFor Each Sht1 In SheetsIf = yl ThenSht1.ActivateMyr1 = [a65536].End(xlUp).Row + 1Cells(Myr1, 1) = Arr2(i, 1)Cells(Myr1, 3) = Arr2(i, 3)Cells(Myr1, 2) = Arr2(i, 4) * Arr(j, 2)Exit ForEnd IfNextNext jGoTo 100End IfNext100:Next iCall qccfApplication.ScreenUpdating = TrueEnd SubSub qccf()Dim Sht As Worksheet, Myr&, Arr, i&, xDim d, k, t, Arr1, j&Application.ScreenUpdating = FalseFor Each Sht In SheetsSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a2:c" & Myr)Set d = CreateObject("Scripting.Dictionary")If Myr < 3 Then GoTo 100For i = 1 To UBound(Arr)x = Arr(i, 1) & "," & Arr(i, 3)If Not d.exists(x) Thend(x) = Arr(i, 2)Elsed(x) = d(x) + Arr(i, 2)End IfNextk = d.keyst = d.itemsReDim Arr1(1 To UBound(k) + 1, 1 To 3)For j = 0 To UBound(k)Arr1(j + 1, 1) = Split(k(j), ",")(0)Arr1(j + 1, 3) = Split(k(j), ",")(1)Arr1(j + 1, 2) = t(j)Next jRange("a2:c" & Myr).ClearContents[a2].Resize(UBound(Arr1), 3) = Arr1100:Set d = NothingNextApplication.ScreenUpdating = TrueEnd Sub8，多工作簿对比（FileSearch）‘/viewthread.php?tid=499599&pid=3285214&page=1&extra=page%3D1Sub dgzbdb()'多工作簿对比'by:蓝桥 2009-11-7Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, nm$, myfileDim Sht1 As Worksheet, sh As WorksheetDim wb1 As Workbook, yf, j&, m1&Dim m, arr, r1Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume NextSet wb1 = ThisWorkbookSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathFor Each Sht1 In SheetsIf InStr(Sht1.[a1], "费用明细表") > 0 Thennm = Left(Sht1.[a1], Len(Sht1.[a1]) - 5)Sht1.ActivateWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = nm & ".xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenmyfile = .FoundFiles(1)Workbooks.Open myfileDim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.ActiveSheetm = sh.[a65536].End(xlUp).Rowarr = sh.Range(Cells(2, 1), Cells(m, 6))yf = Val(Split(arr(2, 1), ".")(1))Sht1.ActivateFor j = 1 To UBound(arr)Set r1 = Sht1.Range("c:c").Find(arr(j, 3))If r1 Is Nothing Thenm1 = Sht1.[d65536].End(xlUp).RowCells(m1, 1).EntireRow.Insert shift:=xlUpCells(m1, 1) = Cells(m1 - 1, 1) + 1Cells(m1, 2) = arr(j, 3)Cells(m1, yf + 3) = arr(j, 6)End IfNext jwb.Close savechanges:=FalseSet wb = NothingEnd IfEnd WithEnd IfNextSet myFs = NothingApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub9，多工作簿汇总（FileSearch+字典）‘/viewthread.php?tid=504957&pid=3323070&page=1&extra=page%3D 1Sub pldrwb1123()'合并.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, y&, bb, j&, xDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, Arr, r1, mm&Dim d, k, t, d1, t1Application.ScreenUpdating = Falsemm = 8Set Sht1 = ActiveSheetSht1.[a8:h1000].ClearContentsSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "合并" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookm = [a65536].End(xlUp).RowArr = Range(Cells(8, 1), Cells(m, 7))Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")For j = 1 To UBound(Arr)x = Year(Arr(j, 1)) & "年" & Month(Arr(j, 1)) & "月" & "|" & Arr(j, 2) & "|" & Arr(j, 3) & "|" & Arr(j, 5)d(x) = d(x) + Arr(j, 4)d1(x) = Arr(j, 7)Nextk = d.keyst = d.itemst1 = d1.itemsSht1.ActivateFor y = 0 To UBound(k)bb = Split(k(y), "|")Cells(mm, 1) = nm1Cells(mm, 2) = bb(0)Cells(mm, 3) = bb(1)Cells(mm, 4) = bb(2)Cells(mm, 5) = t(y)Cells(mm, 6) = bb(3)Cells(mm, 7) = t(y) * bb(3)Cells(mm, 8) = t1(y)mm = mm + 1Nextwb.Close savechanges:=FalseSet wb = NothingSet d = NothingSet d1 = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub10，多工作簿多工作表提取数据（Do While）‘/viewthread.php?tid=511250&pid=3368549&page=1&extra=page%3D 1‘年度汇总.xlsSub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&Application.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "年度汇总.xls"myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Arr = .Sheets("领料").Range("A1").CurrentRegionFor Each sh In wb.Sheetsshnm = sh.ActivateIf InStr(shnm, "班") > 0 Thencol = 11Elsecol = 7End IfFor i = 2 To UBound(Arr)If Arr(i, col) = shnm Thenm = sh.[a65536].End(xlUp).Row + 1Cells(m, 1).Resize(1, 12) = Application.Index(Arr, i, 0) End IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&page=1#pid4261137Sub tqsj()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet, pm$Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheet[a2:g1000].ClearContentsfunm = "提取数据.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Activatepm = sh.[a4].ValueMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("b9:e" & Myr)m = m + 1With Sht1.Cells(m, 1) = myName.Cells(m, 2) = pm.Cells(m, 3) = shnm.Cells(m, 4).Resize(UBound(Arr), 4) = ArrEnd Withm = m + UBound(Arr) - 1Next.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=521786&pid=3439524&page=1&extra=page%3D 1‘我想要的结果.xlsSub zdgx()Dim Arr, myPath$, myName$, sh As WorksheetDim m&, funm$, n&, Sht As WorksheetApplication.ScreenUpdating = Falsefunm = "我想要的结果.xls"Set Sht = ActiveSheetSht.[a2:f1000].ClearContentsSht.[a2:f1000].Borders.LineStyle = xlNonemyPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")n = 2Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set sh = .Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowArr = sh.Range("a2:f" & m)Cells(n, 1).Resize(m - 1, 6) = Arrn = n + m - 1.Close FalseEnd WithmyName = DirLoopSht.Range("a2:f" & n - 1).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub‘.excelpx./dispbbs.asp?boardid=5&id=113181&star=1#1455753‘汇总工作表.xls 2010-2-7Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = m + 1Sht1.Cells(m, 1).Resize(1, 3) = Application.Index(Arr, i, 0)Sht1.Cells(m, 4) = Arr(i + 1, 3)Sht1.Cells(m, 5) = Arr(i + 2, 3)Sht1.Cells(m, 6) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&pid=4261137&page=1&extra=page%3D 1Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = m + 1Sht1.Cells(m, 1).Resize(1, 3) = Application.Index(Arr, i, 0)Sht1.Cells(m, 4) = Arr(i + 1, 3)Sht1.Cells(m, 5) = Arr(i + 2, 3)Sht1.Cells(m, 6) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/thread-539493-1-1.htmlSub ndhz() ‘设置工作表在此处要用Sheets("汇总")格式Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, n%, i&, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "汇总.xls": n = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")wb.Sheets("汇总").[a2:e100].ClearDo While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb1 = Workbooks(myName)Set sh = wb1.Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowWith wb.Sheets("汇总")n = n + 1.Cells(n, 1) = sh.[b2].Value.Cells(n, 2) = sh.[c2].Value.Cells(n, 3) = Application.Sum(sh.[e2].Resize(m - 1, 1)) .Cells(n, 4) = Application.Sum(sh.[f2].Resize(m - 1, 1)) .Cells(n, 5) = Application.Sum(sh.[g2].Resize(m - 1, 1)) End With.Close FalseEnd WithmyName = DirLoopwb.Sheets("汇总").Range("a2:e" & n).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub'/thread-580459-1-1.html‘ABC.xls 2010-5-28Sub dgzbsj()Dim Arr, i&, sh$, n&, myPath$, shnm$, nm$, ad$。

VBA工作簿和工作表操作方法既然你已经涉足操作工作表单元格和单元格区域，是时候上一个台阶，学习如何控制单个工作簿，以及整个工作簿集合了。

如果你不知道如何打开一个新工作簿的话，你就不知道准备一个新的电子表格了；如果你不知道如何关闭工作簿，你就不知道如何将工作簿从屏幕上消除。

这些重要的任务由两个VBA方法处理：Add和Close。

下面的练习将给你必要的如何操作工作簿和工作表的语言技巧。

如果你运行了最后一个例子，那么现在你所有的工作簿都已经关闭了。

在你要在工作表上使用前，请确保先打开一个新工作簿。

当你除了单个工作表时，你必须知道如何在工作簿里添加新的工作表，知道如何选择一个或一组工作表，知道如何命名、复制、移动和删除工作表。

在VB里，每个任务都需要一个专门的方法或属性。

注意Select方法和Activate方法之间的区别：当只要一个工作表被选择时，Select和Activate方法可以互换使用如果你要选择一组工作表，Activate方法将让你决定你选中的工作表中哪个要激活。

我们知道，同时只能有一个工作表被激活。

技巧：Sheets（译者简称为“表”）而不是Worksheets（简称为“工作表”）除了工作表之外，工作簿集合里还包括图表。

使用Add方法在工作簿里添加一个新图表：Charts.Add统计图表数目，使用：Charts.Count在Excel 97之前的版本中，工作簿集合里包括两种额外的表：DialogSheets和Modules。

Dialogs已经被更亲切的用户窗体（UserForms）所取代了。

从Excel 97开始，对话框和模块都被创建在VB编辑器窗口里面了。

操作窗口（Windows）当在好几个Excel工作簿上工作，并且需要比较或者巩固数据，或当你想要看同一个工作表里的不同部分时，你很可能要用到Excel“窗口”菜单里的选项：新建窗口和重排窗口。

我们来看看如何通过VBA 来安排窗口。

当你在屏幕上显示窗口时，你可以决定如何排列它们。

VBA的工作簿与工作表操作指南VBA（Visual Basic for Applications）是一种用于自动化任务和增强功能的编程语言。

在Excel中，VBA被广泛用于操作工作簿和工作表，以及执行各种数据处理和分析任务。

本文将为您提供一份VBA的工作簿与工作表操作指南，帮助您更好地掌握这些操作。

一、工作簿操作1. 打开和保存工作簿在VBA中，您可以使用Workbooks.Open方法打开一个已存在的工作簿，并使用SaveAs方法保存工作簿到指定的目录。

以下是一个示例代码：```vbaSub OpenAndSaveWorkbook()Dim wb As WorkbookSet wb = Workbooks.Open("C:\Path\To\Your\File.xlsx")' 在这里进行您的操作wb.SaveAs "C:\Path\To\Your\New\File.xlsx"wb.CloseEnd Sub```2. 新建工作簿使用Workbooks.Add方法可以创建一个新的工作簿，并在其中添加一个新的工作表。

以下是一个示例代码：```vbaSub CreateNewWorkbook()Dim wb As WorkbookDim ws As WorksheetSet wb = Workbooks.AddSet ws = wb.Worksheets(1)' 在这里进行您的操作wb.SaveAs "C:\Path\To\Your\New\File.xlsx"wb.CloseEnd Sub```3. 循环遍历工作簿您可以使用Workbooks集合和For Each循环来遍历当前已打开的工作簿。

以下是一个示例代码：```vbaSub LoopThroughWorkbooks()Dim wb As WorkbookFor Each wb In Workbooks' 在这里进行您的操作wb.Close SaveChanges:=TrueNext wbEnd Sub```二、工作表操作1. 选择工作表通过使用Worksheets集合以及工作表的名称或索引，您可以选择特定的工作表进行操作。

VBA从零学习之8——工作表事件案例背景：我们在数据模板中，希望用户填入的日期，通常为8位数字，如：20170919。

或者是我们设置单元格格式为'emmdd'或'yyyymmdd'，这样不管用户输入的内容是2017-9-19还是2017/9/19，单元格的内容都会显示为20170919。

但这样还不够，用户如果输入了20171301或20170940这样的错误日期，我们希望能即时给用户一个提示。

这个提示，我们可以通过数据有效性里的自定义函数来实现，也可以通过VBA代码来实现。

既然这一系列我们讲的是VBA，就来看看怎么通过VBA来实现吧。

分析需求：我们希望用户在输入单元格内容后，回车时，或者是选择其他单元格的时候，自动弹出对话框进行提示。

联想一下我们之前见过的对象成员(传送门)，它包括属性、方法、事件。

我们在其中提到了事件的例子：比如张三饿了，张三吃饱了，张三开始跑步了，张三结束单身了，张三最终还是被甩了(可怜的程dan序shen员gou)……对应到Excel中，工作簿被打开时，工作簿被保存前，选择的单元格变更时，单元格内容变更后这样，我们就可以在单元格内容变更的事件发生时，编写代码以满足我们的需求。

查找事件：打开VBA编辑器，我们可以看到编辑器左侧有Sheet1、Sheet2、Sheet3、ThisWorkbook这样的列表。

这些都是当前工作簿的成员。

我们双击Sheet1，编辑器右侧会自动打开一个新的空窗口。

然后我们在空窗口的顶端，“通用”下拉列表处选择Worksheet接下来，空窗口中会出现一些代码。

我们在右侧的下拉框(这里就是Worksheet的事件成员的清单了)再选择Change。

最终窗口的代码如下：(其中Sub Worksheet_SelectionChange，是我们在选择Worksheet时，自动为默认事件SelectionChange生成的代码；Sub Worksheet_Change是我们在选择Change事件时自动生成的代码。

VBA中的工作表与工作簿操作VBA（Visual Basic for Applications）是一种用于自动化任务和宏编程的编程语言，常用于Microsoft Office中的应用程序，如Excel、Word和PowerPoint。

在VBA中，工作表和工作簿是非常重要的对象，它们允许我们在Excel应用程序中进行数据操作和处理。

工作表是Excel中的一个单页，用于存储和组织数据。

而工作簿则是包含多个工作表的文件，类似于一个电子表格或工作簿。

在VBA中，我们可以使用各种方法和属性来操作工作表和工作簿，以实现自动化任务和数据处理。

首先，我们可以使用VBA中的对象模型来引用和操作工作表和工作簿。

对于工作表，我们可以使用`Worksheets`集合对象来引用和创建新的工作表。

例如，以下代码将创建一个名为"新工作表"的工作表：```Dim ws As WorksheetSet ws = Worksheets.Add = "新工作表"```我们还可以使用`ActiveWorksheet`属性来引用当前激活的工作表。

例如，以下代码将激活名为"Sheet2"的工作表：```Worksheets("Sheet2").Activate```对于工作簿，我们可以使用`Workbooks`集合对象来引用和创建新的工作簿。

例如，以下代码将创建一个名为"新工作簿"的工作簿：```Dim wb As WorkbookSet wb = Workbooks.Addwb.SaveAs "新工作簿.xlsx"```我们还可以使用`ActiveWorkbook`属性来引用当前激活的工作簿。

例如，以下代码将激活名为"Book2"的工作簿：```Workbooks("Book2.xlsx").Activate```在VBA中，我们还可以使用各种方法和属性来对工作表和工作簿进行常见的操作，例如插入、删除和复制。

VBA中的工作表与工作簿操作指南在使用VBA（Visual Basic for Applications）编程时，掌握如何操作工作表和工作簿是非常重要的。

工作表和工作簿是Excel中最基本的组成部分，通过VBA可以实现自动化、批量处理和数据分析等功能。

本文将介绍如何通过VBA进行工作表和工作簿的常见操作。

一、工作表的操作1. 新增工作表要在VBA中新增一个工作表，可以使用Worksheets.Add方法。

下面的示例演示了如何在活动工作簿中新增一个名为"Sheet2"的工作表：```Sub AddWorksheet()Dim ws As WorksheetSet ws = ThisWorkbook.Worksheets.Add = "Sheet2"End Sub```2. 删除工作表要删除一个工作表，可以使用Worksheets.Delete方法。

下面的示例演示了如何删除名为"Sheet1"的工作表：```Sub DeleteWorksheet()Dim ws As WorksheetSet ws = ThisWorkbook.Worksheets("Sheet1")Application.DisplayAlerts = False '禁止弹出确认对话框 ws.DeleteApplication.DisplayAlerts = True '恢复弹出确认对话框End Sub```3. 选择工作表使用Sheets对象的方法可以选择特定工作表。

下面的示例演示了如何选择名为"Sheet3"的工作表：```Sub SelectWorksheet()ThisWorkbook.Sheets("Sheet3").SelectEnd Sub```4. 复制工作表要复制一个工作表，可以使用Worksheets.Copy方法。