EXCEL重要宏应用，序号的使用方法EXCEL重要宏应用，序号的使用方法 (1)1 序号 (2)1.1 . 希望在B列输入内容,A列就自动进行编号 (2)1.2 . 隐藏行连续 (2)2 安全 (2)2.1 . 保护工作表 (2)3 宏 (2)3.1 . 批量将工作表转换为独立工作簿 (2)3.2 . 一键汇总各分表数据到总表 (3)3.3 . 一键将总表数据拆分为多个分表 (4)3.4 . 汇总多个工作簿的数据到总表 (6)3.5 . 按一列中的部门拆分成工作簿 (8)3.6 . 按一列中的部门拆分成工作簿 (10)3.7 . 将同一工作簿中的所有工作表合并到一个工作表中 (12)3.7.1 代码1 (12)3.7.2 代码2 (13)3.8 . 把一个工作簿中的所有表单合并成一个表单，怎么去掉重复的表头、标题行？方法如下： (13)3.8.1 代码1 (13)3.8.2 代码2 (13)3.9 . 将需要合并的工作簿文件放置在一个文件夹中，并新建一个工作簿 (14)1 序号1.1 . 希望在B列输入内容,A列就自动进行编号在A2单元格中输入公式:=IF(B2="","",COUNTA($B$2:B2))1.2 . 隐藏行连续在A2单元格输入公式:=IF(B2="","",SUBTOTAL(103,$B$2:B2))2 安全2.1 . 保护工作表按 Ctrl+G，打开定位条件对话框，选择定位到“公式”；2、按Ctrl+1，打开单元格设置对话框，在“保护”选项下，勾选“隐藏”和“锁定”；3、在“审阅”选项下的“保护工作表”中设置撤销保护的密码，确定，即可达到隐藏公式的效果。
3 宏3.1 . 批量将工作表转换为独立工作簿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.SaveAsstrPath&, xlWorkbookDefault'保存活动工作薄到指定路径下，以默认文件格式.Close True '关闭工作薄并保存End WithNextApplication.ScreenUpdating = True '恢复屏幕刷新Application.DisplayAlerts = True '恢复显示系统警告和消息MsgBox "处理完成。
", , "提醒"End Sub3.2 . 一键汇总各分表数据到总表Sub collect()'VBA编程学习与实践，一键多表数据汇总Dim sht As Worksheet, rng As Range, k&, trow&Application.ScreenUpdating = False'取消屏幕更新，加快代码运行速度trow = Val(InputBox("请输入标题的行数", "提醒"))If trow< 0 Then MsgBox "标题行数不能为负数。
", 64, "警告": Exit Sub'取得用户输入的标题行数，如果为负数，退出程序Cells.ClearContents'清空当前表数据For Each sht In Worksheets'循环读取表格If <> Then'如果表格名称不等于当前表名则进行汇总动作……Set rng = edRange'定义rng为表格已用区域k = k + 1'累计K值If k = 1 Then'如果是首个表格，则K为1，则把标题行一起复制到汇总表rng.Copy[a1].PasteSpecial Paste:=xlPasteValuesElse'否则，扣除标题行后再复制黏贴到总表，只黏贴数值rng.Offset(trow).CopyCells(edRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValuesEnd IfEnd IfNext[a1].Activate'激活A1单元格Application.ScreenUpdating = True'恢复屏幕刷新End Sub3.3 . 一键将总表数据拆分为多个分表Sub NewShts()Dim d As Object, sht As Worksheet, arr, brr, r, kr, i&, j&, k&, x&Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&Application.ScreenUpdating = False '关闭屏幕更新Application.DisplayAlerts = False '关闭警告信息提示Set d = CreateObject("scripting.dictionary") 'set字典Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)'用户选择的拆分依据列tCol = Rg.Column '取拆分依据列列标tRow = Val(Application.InputBox("请输入总表标题行的行数？"))'用户设置总表的标题行数If tRow = 0 Then MsgBox "你未输入标题行行数，程序退出。
": Exit SubSet Rng = edRange '总表的数据区域arr = Rng '数据范围装入数组arrtCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置aCol = UBound(arr, 2) '数据源的列数For i = tRow + 1 To UBound(arr) '遍历数组arrIf Not d.exists(arr(i, tCol)) Thend(arr(i, tCol)) = i '字典中不存在关键词则将行号装入字典Elsed(arr(i, tCol)) = d(arr(i, tCol)) & "," &i '如果存在则合并行号，以逗号间隔End IfNextFor Each sht In Worksheets '遍历一遍工作表，如果字典中存在则删除If d.exists() Then sht.DeleteNextkr = d.keys '字典的key集For i = 0 To UBound(kr) '遍历字典key值If kr(i) <> "" Then '如果key不为空r = Split(d(kr(i)), ",") '取出item里储存的行号ReDimbrr(1 To UBound(r) + 1, 1 To aCol) '声明放置结果的数组brrk = 0For x = 0 To UBound(r)k = k + 1 '累加记录行数For j = 1 To aCol '循环读取列brr(k, j) = arr(r(x), j)NextNextWith Worksheets.Add(, Sheets(Sheets.Count))'新建一个工作表，位置在所有已存在sheet的后面.Name = kr(i) '表格命名.[a1].Resize(tRow, aCol) = arr '放标题行.[a1].Offset(tRow, 0).Resize(k, aCol) = brr '放置数据区域 Rng.Copy '复制粘贴总表的格式.[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False.[a1].SelectEnd WithEnd IfNextSheets(1).Activate '激活第一个表格Set d = Nothing '释放字典Erase arr: Erase brr '释放数组MsgBox "数据拆分完成！"Application.ScreenUpdating = True '恢复屏幕更新Application.DisplayAlerts = True '恢复警示End Sub3.4 . 汇总多个工作簿的数据到总表Sub CollectWorkBookDatas()Dim ShtActive As Worksheet, rngData As Range, ShtData As WorksheetDim lngHeadLine As Long, k As LongDim i As Long, j As Long, n As LongDim aData, aResultDim strPath As String, strFileName As StringDim strKey As String, lngShtCount As Long, lngTemp As LongOn Error Resume NextWith Application.FileDialog(msoFileDialogFolderPicker)'取得用户选择的文件夹路径If .Show Then strPath = .SelectedItems(1) Else Exit SubEnd WithIf Right(strPath, 1) <> "\" Then strPath = strPath& "\"strKey = InputBox("请输入需要合并的工作名称表包含的关键字: ", "Reminder")If StrPtr(strKey) = 0 Then Exit Sub'如果点击了取消或者关闭按钮，则退出程序lngHeadLine = Val(InputBox("Please input the header line quantity", "Reminder", 1))'用户输入标题行，默认值为1If lngHeadLine< 0 Then MsgBox "请输入标题行的行数. ", 64, "my user": Exit SubSet ShtActive = ActiveSheetWith Application.ScreenUpdating = False.DisplayAlerts = False.AskToUpdateLinks = FalseEnd WithConst DATA_MAXROW As Long = 50000 '结果数组最大行数Const WK_SHT_NAME As Long = 2 '前面两列是工作簿和工作表名称的标题ReDimaResult(1 To DATA_MAXROW, -1 To 1) '声明结果数组Cells.Clear '清除原表内容strFileName = Dir(strPath& "*.xlsx*")'使用Dir函数遍历excel文件Do While strFileName<> ""If strFileName<> Then '避免同名文件重复打开出错With GetObject(strPath&strFileName)'以只读'形式读取文件时，使用getobject会比workbooks.open稍快 For Each ShtData In .Worksheets '遍历表If InStr(1, , strKey, vbTextCompare) Then '如果表中包含关键字则进行汇总(不区分关键词字母大小写）Set rngData = edRangeIf IsEmpty(rngData) = False Then'如果工作表非空……lngShtCount = lngShtCount + 1 '标记一下汇总工作表的个数aData = rngData.Value '数据区域读入数组aData If UBound(aData, 2) >UBound(aResult, 2) Then '动态调整结果数组aResult的最大列数，避免明细表列数不一的情况。