excel常用代码集合(非常重要).docxVIP

批量 将 工作表 转换为独 立工作簿 Sub Newbooks() EH 技 术 论坛。 VBA 编 程 学习与 实践 。看 见星 光 Dim sht As Worksheet, strPath$ With Application.FileDialog(msoFileDialogFolderPicker) 选择保存工作薄的文件路径 If .Show Then strPath = .SelectedItems(1) 读取选择的文件路径 Else Exit Sub 如果没有选择保存路径，则退出程序 End If End With If Right(strPath, 1) \ Then strPath = strPath \ Application.DisplayAlerts = False 取消显示系统警告和消息，避免重名工作簿无法保存。当有重名工作簿时，会直接覆 盖保 存 。 Application.ScreenUpdating = False 取消屏幕刷新 For Each sht In Worksheets 遍历工作表 sht.Copy 复 制 工作 表，工作 表 单 纯复 制 后 ，会 成为 活 动工作 薄 With ActiveWorkbook .SaveAs strPath sht.Name, xlWorkbookDefault 保存活动工作薄到指定路径下，以默认文件格式 .Close True 关 闭 工 作 薄 并 保 存 End With Next Application.ScreenUpdating = True 恢 复 屏 幕 刷 新 Application.DisplayAlerts = True 恢 复 显 示 系 统 警 告 和 消 息 MsgBox 处 理完 成 。 , , 提 醒 End Sub 一 键将总 表数 据拆分 为多个分表 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 Sub Set Rng = ActiveSheet.UsedRange 总表的 数据区域 arr = Rng 数据范 围装入 数组 arr tCol = tCol - Rng.Column + 1 计 算依据列在 数组 中的位置 aCol = UBound(arr, 2) 数 据源的列 数 For i = tRow + 1 To UBound(arr) 遍 历数组 arr If Not d.exists(arr(i, tCol)) Then d(arr(i, tCol)) = i 字典中不存在 关键词则将 行 号装入字典 Else d(arr(i, tCol)) = d(arr(i, tCol)) , i 如果存在 则 合并 行 号，以逗 号间 隔 End If Next For Each sht In Worksheets 遍历 一遍工作表，如果字典中存在 则删 除 If d.exists(sht.Name) Then sht.Delete Next kr = d.keys 字典的 key 集 For i = 0 To UBound(kr) 遍历 字典 key 值 If kr(i) Then 如果 key 不为 空 r = Split(d(kr(i)), ,) 取出 item 里 储存的行 号 ReDim brr(1 To UBound(r) + 1, 1 To aCol) 声 明放置 结 果的 数组 brr k = 0 For x = 0 To UBound(r) k = k + 1 累加 记录 行 数 For j = 1 To aC