VBA工作薄工作表事件一览表

合集下载

ExcelVBA解读（80）：看看工作表会自动响应哪些操作——认识工作表事件

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所示。

利用VBA统计各个工作表的记录数目

统计各个工作‎表记录数目1、代码即说明括号内红色字‎体为代码说明‎。

代码如下：Sub 统计各工作表‎记录的数目()Dim n%n = Sheets‎.Count（n表示当前工‎作簿工作表的‎数量）Worksh‎e ets.Add after:=Sheets‎(Sheets‎.Count)（表示在最后一‎张工作表后面‎新建一张工作‎表）Active‎ = "数据统计"（新建的工作表‎命名为“数据统计”）Dim row As Longrow = 1Dim num As LongFor row = 1 To nCells(row, 1) = Sheets‎(row).Namenum = 2DoIf Sheets‎(row).Cells(num, 1) <> "" Thennum = num + 1Else: GoTo loop1End IfLooploop1:num = num - 2Sheets‎(n + 1).Cells(row, 2) = numNextEnd Sub2、实例该工作簿有四‎张工作表，分别为“鸡屁股”、“鸡脚”、“鸡腿”、“鸡翅”。

剩下三张表如‎上图所示。

运行代码结果‎为：3、注意事项（1）该代码记录的‎判断标准为，A列单元格不‎为空格，则num加1‎，所以务必保证‎每条记录的A‎列不为空格（2）同工作簿的工‎作表名字不能‎相同，所以，如果工作簿中‎已经存在名为‎“数据统计”的工作表，则代码会发生‎错误（3）默认原工作表‎第一行均为表‎头，不算记录数目‎当中。

工作薄、工作表VBA事件程序一览表

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 中的工作表和工作簿操作方法

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代码以下是一个用于将不同工作簿数据汇总的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`的工作簿的"数据"工作表数据汇总到当前工作簿的"汇总"工作表中。

VBA开发中的工作簿与工作表操作

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记录Excel工作表打开、关闭的时间与次数

阅读留痕---VBA记录Excel表的打开、关闭的时间与次数工作中，你是不是经常遇到这样的事：文件修改了无数次，文件的后缀名由“***修改版”、“***终版”、“***最终版”、“***最最终版”等等的修改，最后不知道到底哪一版是终稿了，只记得某个时间段修改的算是最后一版，可哪个版本才是呢？要是能记录工作表打开和关闭的时间就好了。

现在，我们就用Excel工作表打开、关闭触发时件记录工作表的浏览记录。

老规矩，直接上思路和代码。

1、打开Excel表，直接添加一张工作表，命名为“浏览记录”。

为防止有重名的工作表，先遍历工作表中有无“浏览记录”的工作表，没有就添加。

为防止后期误删该工作表，工作表添加后直接隐藏。

代码如下：1.1 添加工作表方法Function addWorkSheet()Dim ws As WorksheetDim NewCopySheet As WorksheetDim i As Integeri = 0Dim SheetName As StringSheetName = "浏览记录"On Error Resume Next '代码出错时继续运行Application.DisplayAlerts = False '防提示For Each ws In Worksheets '遍历工作表，查看是否有“浏览记录”的工作表 If = SheetName Theni = 1 '若有，变量赋值为1End IfNextIf i = 0 Then '没有，添加工作表，放在最后Sheets.Add after:=Sheets(Sheets.Count)Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) = SheetName '工作表重命名为“浏览记录”End IfCall VeryHiddenSheet(SheetName) '调用隐藏工作表方法Call RecordOpen(SheetName) '调用记录方法End Function1.2隐藏工作表方法Function VeryHiddenSheet(ws) '留指定工作表,其余隐藏Dim Sheets As WorksheetApplication.DisplayAlerts = False '防提示'遍历工作表For Each Sheets In WorksheetsIf = ws Then '判断工作表名称，是的隐藏。

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

V B A工作薄工作表事件一览表集团标准化工作小组 [Q8QX9QT-X8QQB8Q8-NQ8QJ8-M8QMN]翻箱倒柜，无意中发现个好东东放到这里，大家查着也方便工作簿对象事件一览表当工作簿更改、工作簿中的任何工作表更改、加载宏更改或数据透视表更改时，将引发工作簿事件。

工作簿上的事件在默认情况下是可用的。

若要查看工作簿的事件过程，请用鼠标右键单击处于还原状态或最小化状态的工作簿窗口标题栏，再单击快捷菜单上的“查看代码”。

在“过程”下拉列表框内选择事件名称。

事件说明Activate激活工作薄时AddinInstall当工作簿作为加载宏安装时AddinUninstall工作簿作为加载宏卸载时BeforeClose关闭工作薄前BeforePrint打印工作薄(或其中任何内容)之前BeforeSave保存工作薄前Deactivate工作簿从活动状态转为非活动状态时NewSheet在工作簿中新建工作表时Open打开工作簿时PivotTableCloseConnection在数据透视表关闭与其数据源的连接之后PivotTableOpenConnection在数据透视表打开与其数据源的连接之后SheetActivate激活任何一张表时SheetBeforeDoubleClick双击任何工作表时SheetBeforeRightClick鼠标右键单击任一工作表时SheetCalculate工作表重新计算时SheetChange更改工作表中的单元格时SheetDeactivate任一工作表由活动状态转为非活动状态时SheetFollowHyperlink单击 Microsoft Excel 中的任意超链接时SheetPivotTableUpdate数据透视表的工作表更新之后SheetSelectionChange工作簿中的数据透视表更新之后WindowActivate工作簿的窗口激活时WindowDeactivate工作簿的窗口变为非活动状态时WindowResize工作簿窗口调整大小时本示例在打开工作簿时将 Microsoft Excel 窗口最大化。

ExcelVBA解读（93）：工作簿对象的SheetActivate、SheetDeact。。。

ExcelVBA解读（93）：⼯作簿对象的SheetActivate、SheetDeact。

本⽂详细讲解Workbook对象的3个事件：SheetActivate事件、SheetDeactivate事件和SheetSelectionChange事件。

Workbook_SheetActivate事件当激活任意⼯作表时发⽣Workbook_SheetActivate事件。

其语法为：Workbook_SheetActivate(ByVal Sh As Object)说明：参数Sh，必需，表⽰被激活的⼯作表，可以是图表⼯作表或标准⼯作表。

在ThisWorkbook代码模块中输⼊下⾯的代码，当激活⼯作表时弹出⼀个显⽰该⼯作表名字的消息框：Private SubWorkbook_SheetActivate(ByVal Sh As Object)MsgBox '当前⼯作表是:' & End SubWorkbook_SheetDeactivate事件当使⼯作表变为⾮活动⼯作表时发⽣Workbook_SheetDeactivate事件。

其语法为：Workbook_SheetDeactivate(ByVal Sh As Object)说明：参数Sh，必需，表⽰变为⾮活动⼯作表的⼯作表，可以是图表⼯作表或标准⼯作表。

在ThisWorkbook代码模块中输⼊下⾯的代码，当使⼯作表变为⾮活动⼯作表时弹出⼀个显⽰该⼯作表名字的消息框：Private SubWorkbook_SheetDeactivate(ByVal Sh As Object)MsgBox '⾛了,⼯作表:' & End Sub当SheetActivate事件和SheetDeactivate事件都存在时，先发⽣SheetDeactivate事件，再发⽣SheetActivate事件。

Workbook_SheetSelectionChange事件当改变任意⼯作表（图表⼯作表除外）的单元格选择时发⽣Workbook_SheetSelectionChange事件。

ExcelVBA解读（81）：工作表事件示例

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所示的自定义输入框。

Excel VBA_多工作簿多工作表格汇总情况实例集锦

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的事件处理与触发方法VBA（Visual Basic for Applications）是用于Microsoft Office应用程序（如Excel、Word和Access）的编程语言。

利用VBA，用户可以通过编写宏或自定义函数来自动化任务和增强应用程序的功能。

在VBA中，事件处理是一种非常重要的编程技术，能够根据特定的条件或操作在程序中触发相应的动作或命令。

本文将重点介绍VBA中的事件处理与触发方法，包括常见的事件类型和如何编写事件处理程序。

事件类型在VBA中，有许多不同的事件可以触发特定的动作。

下面是一些常见的事件类型：1. Workbook Events（工作簿事件）：当Excel工作簿被打开、关闭、保存、激活或更改时触发相应的事件。

2. Worksheet Events（工作表事件）：当Excel工作表被激活、更改选定的区域或选定的单元格时触发相应的事件。

3. UserForm Events（用户窗体事件）：当用户窗体中的控件被点击、键盘输入或激活时触发相应的事件。

4. Button Events（按钮事件）：当按钮被点击时触发相应的事件。

5. TextBox Events（文本框事件）：当文本框中的文本发生更改、按下某个键或获得焦点时触发相应的事件。

编写事件处理程序编写VBA事件处理程序是实现程序自动化和增强功能的关键。

下面是编写事件处理程序的基本步骤：1. 打开代码窗口：要编写事件处理程序，首先需要打开VBA编辑器。

在Excel中，可以按下“Alt + F11”快捷键来打开VBA编辑器。

2. 选择对象和事件：在代码窗口中，需要选择发生事件的对象和事件类型。

例如，要处理工作表中的更改事件，需要选择工作表对象和Change事件。

3. 编写事件处理程序：在选定的对象和事件下，编写相应的事件处理程序。

事件处理程序是一段VBA代码，它定义了在事件发生时要执行的操作。

例如，当工作表的选定范围更改时，可以编写一个事件处理程序来计算和显示更改后的值。

excel中VBA事件

excel中VBA事件Excel事件表一工作簿对象事件一览表当工作簿更改、工作簿中的任何工作表更改、加载宏更改或数据透视表更改时，将引发工作簿事件。

工作簿上的事件在默认情况下是可用的。

若要查看工作簿的事件过程，请用鼠标右键单击处于还原状态或最小化状态的工作簿窗口标题栏，再单击快捷菜单上的“查看代码”。

在“过程”下拉列表框内选择事件名称。

事件说明Activate激活工作薄时AddinInstall当工作簿作为加载宏安装时AddinUninstall工作簿作为加载宏卸载时BeforeClose关闭工作薄前BeforePrint打印工作薄(或其中任何内容)之前BeforeSave保存工作薄前Deactivate工作簿从活动状态转为非活动状态时NewSheet在工作簿中新建工作表时Open打开工作簿时PivotTableCloseConnection在数据透视表关闭与其数据源的连接之后PivotTableOpenConnection在数据透视表打开与其数据源的连接之后SheetActivate激活任何一张表时SheetBeforeDoubleClick双击任何工作表时SheetBeforeRightClick鼠标右键单击任一工作表时SheetCalculate工作表重新计算时SheetChange更改工作表中的单元格时SheetDeactivate任一工作表由活动状态转为非活动状态时SheetFollowHyperlink单击Microsoft Excel中的任意超链接时SheetPivotTableUpdate数据透视表的工作表更新之后SheetSelectionChange工作簿中的数据透视表更新之后WindowActivate工作簿的窗口激活时WindowDeactivate工作簿的窗口变为非活动状态时WindowResize工作簿窗口调整大小时2工作表事件一览表工作表上的事件在默认情况下是可用的。

VBA工作薄、工作表事件一览表

[VBA程序开发]工作薄、工作表事件一览表[复制链接]翻箱倒柜，无意中发现个好东东放到这里，大家查着也方便工作簿对象事件一览表当工作簿更改、工作簿中的任何工作表更改、加载宏更改或数据透视表更改时，将引发工作簿事件。

工作簿上的事件在默认情况下是可用的。

若要查看工作簿的事件过程，请用鼠标右键单击处于还原状态或最小化状态的工作簿窗口标题栏，再单击快捷菜单上的“查看代码”。

在“过程”下拉列表框内选择事件名称。

VBA从零学习之8——工作表事件

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事件时自动生成的代码。

ExcelVBA入门（6）-Worksheet对象常用方法事件

ExcelVBA⼊门（6）-Worksheet对象常⽤⽅法事件1. 激活⼯作表 ActiveDim ws As WorksheetSet ws = Application.WorkBooks(1).Worksheets(2)ws.Activate激活了第⼀个⼯作簿的Sheet22. 复制⼯作表 Copy([before], [after])将当前⼯作表复制⼀份, 名字为"当前⼯作表名字(2)"Dim ws As WorksheetSet ws = Application.ActiveWorkbook.Worksheets(1)ws.Copy after:=Worksheets(1)该代码将Sheet1的内容拷贝到新表Sheet1(2)如果不指定before或after, 同样会⽣成⼀个新表, 注意, before和after不能同时使⽤另外, ⼯作表的复制可以跨⼯作簿之间进⾏Dim wbSrc As WorkbookDim wbDes As WorkbookDim ws As WorksheetSet wbSrc = Application.WorkBooks(1)Set wbDes = Application.WorkBooks.AddSet ws = wbSrc.Worksheets(1)ws.Copy after:=wbDes.Worksheets(1)将当前⼯作表的内容复制到新⼯作簿的第2个⼯作表3. 将剪贴板的内容粘贴到⼯作表Paste([destination], [link])Dim ws As WorksheetSet ws = Application.ActiveWorkbook.ActiveSheetws.range("A1:A3").Copyws.Paste destination:=ws.range("F1:F3")先将A1:A3的内容复制到剪贴板, 然后利⽤Paste⽅法, 粘贴到F1:F3区域, 亦或者直接:ws.range("A1:A3").Copyws.Paste destination:=ws.range("F1")Worksheet事件:和Workbook的事件类似, 在"⼯程资源管理器"中, 双击⼀个⼯作表, 在右边代码区上⾯选择Worksheet, 然后再选择相应的事件选择⼀个事件会⾃动列出事件代码常⽤的操作⼯作表的⽅法1. 访问⼯作表两种⽅式: a. 根据索引号(从1开始) b.根据⼯作表名称Dim wb As WorkbookDim ws As WorksheetDim wsCount As IntegerDim i As IntegerDim sheetnames() As StringSet wb = Application.WorkBooks(1)wb.ActivatewsCount = wb.Worksheets.CountReDim sheetnames(1 To wsCount)PrintInfo "当前⼯作簿共包含" & CStr(wsCount) & "个⼯作表"For i = 1 To wsCountSet ws = wb.Worksheets(i)Debug.Print Space(5) & sheetnames(i) = NextDebug.PrintDebug.Print "使⽤Sheets集合按名称访问⼯作表"For i = 1 To wsCountSet ws = wb.Worksheets(sheetnames(i))Debug.Print Space(5) & NextSet ws = NothingSet wb = Nothing例⼦⽐较简单, 说明⼀下Space(5)的意思是五个空格, CStr()是把参数转换为字符串核⼼就是 Worksheets(1) 和Worksheets("Sheet1") 是等效的 (默认没有改⼯作表名字⽽且没有移动⼯作表顺序的情况下)另外在遍历⼯作表的时候使⽤的是Worksheets属性, 如果使⽤Sheets属性则需要判断⼯作表的类型是普通⼯作表还是图表⼯作表根据Type属性判断: If ws.Type = xlWorksheet Then2. 判断⼯作表是否存在判断⼯作表是否存在就是⽤指定的名称遍历所有⼯作表, 没什么难点Dim wb As WorkbookDim ws As WorksheetDim i As IntegerDim count As IntegerDim flag As BooleanDim findName As StringfindName = "Sheet7"Set wb = Application.ActiveWorkbookcount = wb.Worksheets.countflag = FalseFor i = 1 To countIf wb.Worksheets(i).name = findName Thenflag = TrueExit ForEnd IfNextIf flag ThenMsgBox "存在" & findNameElseMsgBox "不存在" & findNameEnd IfSet ws = NothingSet wb = Nothing这段代码不⽤解释了3.新建⼯作表 Application.ActiveWorkbook.Worksheets.Add([Before], [After], [Count], [Type]) As Object新建⼯作表和之前的新建⼯作簿类似Dim ws As WorksheetSet ws = Worksheets.AddDebug.Print 完整写法Set ws = Application.ActiveWorkbook.Worksheets.Add(before:=Worksheets(8), count:=2, Type:=xlWorksheet)意思是在第8个表前加⼊两个⼯作表同样的Before和After不能同时使⽤4. 重命名⼯作表直接设置⼯作表的name属性即可, 但是要先判断该名称是否已经存在, 否则会报错为了简单说明, 这⾥就不作判断了Dim ws As WorksheetSet ws = Application.WorkBooks(1).Worksheets(1) = "SheeT1"将"Sheet1"重命名为了"SheeT1"5. 移动⼯作表Dim wb As WorkbookDim ws As WorksheetSet wb = Application.WorkBooks(1)wb.ActivateSet ws = wb.Worksheets(1)ws.Move after:=ws.NextSet wb = NothingSet ws = Nothing道理和复制⼀样, ws.Move after:=ws.Next 将第⼀个⼯作表向后移动⼀次同理, 移动也可以跨⼯作簿进⾏Dim wbSrc As WorkbookDim wbDes As WorkbookDim ws As WorksheetSet wbSrc = Application.WorkBooks(1)Set wbDes = Application.WorkBooks.AddSet ws = wbSrc.Worksheets(1)ws.Move after:=wbDes.Worksheets(1)将当前⼯作簿的Sheet1 移动到新的⼯作簿的Sheet1后6. 删除⼯作表注意: 删除前请保存重要数据Dim wb As WorkbookDim ws As WorksheetDim sheetName As StringDim count As IntegerSet wb = Application.WorkBooks(1)Set ws = wb.Worksheets(1)sheetName = count = wb.Worksheets.countIf count > 1 ThenApplication.DisplayAlerts = Falsews.DeleteMsgBox "成功删除" & sheetName, vbOKOnly, "删除⼯作表"Application.DisplayAlerts = TrueElseMsgBox "⼯作表" & sheetName & "是⼯作簿的最后⼀张表, ⽆法删除", vbCritical, "删除⼯作表" End IfSet wb = NothingSet ws = Nothing。

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方法。

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

翻箱倒柜，无意中发现个好东东放到这里，大家查着也方便工作簿对象事件一览表当工作簿更改、工作簿中的任何工作表更改、加载宏更改或数据透视表更改时，将引发工作簿事件。

工作簿上的事件在默认情况下是可用的。

若要查看工作簿的事件过程，请用鼠标右键单击处于还原状态或最小化状态的工作簿窗口标题栏，再单击快捷菜单上的“查看代码”。

在“过程”下拉列表框内选择事件名称。

事件? ? ? ? 说明Activate激活工作薄时AddinInstall当工作簿作为加载宏安装时AddinUninstall工作簿作为加载宏卸载时BeforeClose关闭工作薄前BeforePrint打印工作薄(或其中任何内容)之前BeforeSave保存工作薄前Deactivate工作簿从活动状态转为非活动状态时NewSheet在工作簿中新建工作表时Open打开工作簿时PivotTableCloseConnection在数据透视表关闭与其数据源的连接之后PivotTableOpenConnection在数据透视表打开与其数据源的连接之后SheetActivate激活任何一张表时SheetBeforeDoubleClick双击任何工作表时SheetBeforeRightClick鼠标右键单击任一工作表时SheetCalculate工作表重新计算时SheetChange更改工作表中的单元格时SheetDeactivate任一工作表由活动状态转为非活动状态时SheetFollowHyperlink单击 Microsoft Excel 中的任意超链接时SheetPivotTableUpdate数据透视表的工作表更新之后SheetSelectionChange工作簿中的数据透视表更新之后WindowActivate工作簿的窗口激活时WindowDeactivate工作簿的窗口变为非活动状态时WindowResize工作簿窗口调整大小时本示例在打开工作簿时将 Microsoft Excel 窗口最大化。

Sub Workbook_Open()? ? = xlMaximizedEnd Sub? ? ? ?Activate 事件激活一个工作簿、工作表、图表或嵌入图表时产生此事件。

Private Sub object_Activate()object? ?? ?Chart、Workbook、或者 Worksheet。

有关对 Chart 对象使用事件的详细信息，请参阅图表对象事件的用法。

说明切换两个显示同一个工作簿的窗口时，将产生 WindowActivate 事件，但不产生工作簿的Activate 事件。

新建窗口时不产生本事件。

示例当激活工作表时，本示例对 A1:A10 区域进行排序。

Private Sub Worksheet_Activate()? ? Range("a1:a10").Sort Key1:=Range("a1"), Order:=xlAscendingEnd SubAddinInstall 事件当工作簿作为加载宏安装时，产生此事件。

Private Sub Workbook_AddinInstall()示例当指定工作簿作为加载宏安装时，本示例将一个控件添加到常用工具栏中。

Private Sub Workbook_AddinInstall()? ? With ("Standard").? ?? ???.Caption = "The AddIn's menu item"? ?? ???.OnAction = "''!Amacro"? ? End With End SubEnd Sub? ? ? ? ? ? ? ?AddinUninstall 事件当工作簿作为加载宏卸载时，产生此事件。

Private Sub Workbook_AddinUninstall()说明卸载加载宏时，该加载宏并不自动关闭。

示例当指定工作簿作为加载宏卸载时，本示例将 Microsoft Excel 最小化。

Private Sub Workbook_AddinUninstall()? ? = xlMinimizedEnd SubBeforeClose 事件在关闭工作簿之前，先产生此事件。

如果该工作簿已经更改过，则本事件在询问用户是否保存更改之前产生。

Private Sub Workbook_BeforeClose(Cancel As Boolean)Cancel? ?? ?当事件产生时为 False。

如果该事件过程将本参数设为 True，则停止对工作簿的关闭操作，工作薄仍处于打开状态。

示例本示例将 BeforeClose 事件的响应设置为保存工作簿的任何更改。

Private Sub Workbook_BeforeClose(Cancel as Boolean)? ? If = False ThenEnd Sub? ? ? ? ? ? ? ?BeforePrint 事件在打印指定工作簿（或者其中的任何内容）之前，产生此事件。

Private Sub Workbook_BeforePrint(Cancel As Boolean)Cancel? ?? ?当事件产生时为 False。

如果该事件过程将本参数设为 True，则当该过程运行结束之后不打印工作簿。

示例本示例在打印之前对当前活动工作簿的所有工作表重新计算。

Private Sub Workbook_BeforePrint(Cancel As Boolean)? ? For Each wk in Worksheets? ?? ???? ? NextEnd SubBeforeSave 事件保存工作簿之前产生此事件。

Private Sub Workbook_BeforeSave(ByVal SaveAsUi As Boolean, Cancel As Boolean) SaveAsUi? ?? ?如果显示“另存为”对话框，则为 True。

Cancel? ?? ?当事件产生时为 False。

如果该事件过程将本参数设为 True，则该过程执行结束之后不保存工作簿。

示例本示例在保存工作簿之前询问用户是否保存。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _? ?? ???Cancel as Boolean)? ? a = MsgBox("Do you really want to save the workbook", vbYesNo)? ? If a = vbNo Then Cancel = TrueEnd Sub? ? ? ?Deactivate 事件图表、工作表或工作簿从活动状态转为非活动状态时产生此事件。

Private Sub object_Deactivate()object? ?? ?Chart、Workbook 或者 Worksheet。

有关对 Chart 对象使用事件的详细信息，请参阅 Chart 对象事件的用法。

示例本示例当工作簿转为非活动状态时，对所有打开的窗口进行排列。

Private Sub Workbook_Deactivate()? ? xlArrangeStyleTiledEnd SubNewSheet 事件当在工作簿中新建工作表时产生此事件。

Private Sub Workbook_NewSheet(ByVal Sh As Object)Sh? ?? ?新工作表。

可以是一个 Worksheet 或 Chart 对象。

示例本示例将新建的工作表移到工作簿的末尾。

Private Sub Workbook_NewSheet(ByVal Sh as Object)? ? After:= SheetsEnd Sub? ? ? ?Open 事件打开工作簿时，将产生本事件。

Private Sub Workbook_Open()示例每次打开工作簿时，本示例都最大化 Microsoft Excel 窗口。

Private Sub Workbook_Open()? ? = xlMaximizedEnd Sub? ? ? ?PivotTableCloseConnection 事件发生在数据透视表关闭与其数据源的连接之后。

Private Sub expression_PivotTableCloseConnection(ByVal Target As PivotTable) expression? ?? ?引用在类模块中带有事件声明的 Workbook 类型对象的变量。

Target? ? 必需。

选定的数据透视表。

示例本示例显示一则消息，说明数据透视表与其数据源的连接已经关闭。

本示例假定您已在类模块中声明了带有事件的 Workbook 类型的对象。

Private Sub ConnectionApp_PivotTableCloseConnection(ByVal Target As PivotTable) ? ? MsgBox "The PivotTable connection has been closed."End SubPivotTableOpenConnection 事件发生在数据透视表打开与其数据源的连接之后。

Private Sub expression_PivotTableOpenConnection(ByVal Target As PivotTable) expression? ?? ?引用在类模块中带有事件声明的 Workbook 类型对象的变量。

Target? ? 必需。

选定的数据透视表。

示例本示例显示一则消息，说明数据透视表与其数据源的连接已经打开。

本示例假定您已在类模块中声明了带有事件的 Workbook 类型的对象。

Private Sub ConnectionApp_PivotTableOpenConnection(ByVal Target As PivotTable) ? ? MsgBox "The PivotTable connection has been opened."End SubSheetActivate 事件当激活任何一张表时产生此事件。

Private Sub object_SheetActivate(ByVal Sh As Object)object? ?? ?Application 对象或 Workbook 对象。

Sh? ?? ?激活的表。

可以是一个 Chart 对象或 Worksheet 对象。