Excel VBA 简介及常用代码集锦——1-excel vba代码大全

Sub ml() Dim sht As Worksheet, i&, strShtName$ Columns(1).ClearContents 清空A列数据 Cells(1, 1) = "目录" 第一个单元格写入字符串"目录" i = 1 将i的初值设置为1. For Each sht In Worksheets 循环当前工作簿的每个工作表 strShtName = sht.Name If strShtName <> ActiveSheet.Name Then 如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接 i = i + 1 累加i ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", SubAddress:="" & strShtName & "!a1", TextToDisplay:=strShtName 建超链接 End If Next End Sub

Sub qxyc() Dim sht As Worksheet 定义变量 For Each sht In Worksheets 循环工作簿里的每一个工作表 sht.Visible = xlSheetVisible 将工作表的状态设置为非隐藏 Next End Sub

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 清空当前表数据 Cells.NumberFormat = "@" 设置文本格式 For Each sht In Worksheets 遍历表格 If sht.Name <> ActiveSheet.Name Then 如果表格名称不等于当前表名则进行复制数据…… Set rng = sht.UsedRange 定义rng为表格已用区域 k = k + 1 累计K值 If k = 1 Then 如果是首个表格，则K为1，则把标题行一起复制到汇总表 rng.Copy [a1].PasteSpecial Paste:=xlPasteValues Else 否则，扣除标题行后再复制黏贴到总表，只黏贴数值 rng.Offset(trow).Copy Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues End If End If Next [a1].Activate 激活A1单元格 Application.ScreenUpdating = True 恢复屏幕刷新 End Sub

VBA根据A列数据批量建立工作表的代码如下： Sub NewSht() ExcelHome VBA编程实践与学习 Dim Sht As Worksheet, Rng As Range Dim Sn, t$ Set Rng = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row) 将工作表名称所在的单元格区域赋值给变量Rng，单元格A1是标题，不读入 On Error Resume Next 当代码出错时继续运行 For Each Sn In Rng 遍历Rng(工作表名称集合） t = Sn 还记得这里我们为什么用这句代码吗？ Set Sht = Sheets(t) 当工作簿不存在工作表Sheets(t)时，这句代码会出错，然后…… If Err Then 如果代码出错，说明不存在工作表Sheets(t)，则新建工作表 Worksheets.Add , Sheets(Sheets.Count) 新建一个工作表，位置放在所有已存在工作表的后面 ActiveSheet.Name = t 新建的工作表必然是活动工作表，为之命名 Err.Clear 清除错误状态 End If Next Rng.Parent.Activate 重新激活名称数据所在的工作表 End Sub

Sub SplitShts() Dim d As Object, sht As Worksheet Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x& Dim rngData As Range, rngGist As Range Dim lngTitleCount&, lngGistCol&, lngColCount& Dim rngFormat As Range Dim strKey As String Set d = CreateObject("scripting.dictionary") Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8) ========用户选择的拆分依据列 lngGistCol = rngGist.Column ========拆分依据列的列标 lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？")) ========用户设置总表的标题行数 If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub Set rngData = ActiveSheet.UsedRange ========总表的数据区域 Set rngFormat = ActiveSheet.Cells ========总表的单元格集用于粘贴总表格式 aData = rngData.Value lngGistCol = lngGistCol - rngData.Column + 1 ========计算依据列在数组中的位置 lngColCount = UBound(aData, 2) ========数据源的列数 For i = lngTitleCount + 1 To UBound(aData) If aData(i, lngGistCol) = "" Then aData(i, lngGistCol) = "单元格空白" strKey = aData(i, lngGistCol) ========统一转换为字符串格式 If Not d.exists(strKey) Then ========字典中不存在关键字时将行号装入字典 d(strKey) = i Else d(strKey) = d(strKey) & "," & i ========如果字段存在关键字则合并行号 End If Next Application.DisplayAlerts = False For Each sht In ActiveWorkbook.Worksheets ========删除字典中存在的表名 If d.exists(sht.Name) Then sht.Delete Next Application.DisplayAlerts = True aKeys = d.keys ========字典的key集 Application.ScreenUpdating = False For i = 0 To UBound(aKeys) If aKeys(i) <> "" Then aTemp = Split(d(aKeys(i)), ",") ========取出item里储存的行号 ReDim aResult(1 To UBound(aTemp) + 1, 1 To lngColCount) ========声明放置结果的数组aResult k = 0 For x = 0 To UBound(aTemp) k = k + 1 For j = 1 To lngColCount aResult(k, j) = aData(aTemp(x), j) Next Next With Worksheets.Add(, Sheets(Sheets.Count)) ========新建一个工作表 .Name = aKeys(i) .[a1].Resize(UBound(aData), lngColCount).NumberFormat = "@" ========设置单元格为文本格式 If lngTitleCount > 0 Then .[a1].Resize(lngTitleCount, lngColCount) = aData ========标题行 .[a1].Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult ========数据 rngFormat.Copy .[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ========复制粘贴总表的格式 .[a1].Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete ========删除多余的格式单元格 .[a1].Select End With End If Next rngData.Parent.Activate ========激活总表 Application.ScreenUpdating = True Set d = Nothing Set rngData = Nothing Set rngGist = Nothing Set rngFormat = Nothing Erase aData: Erase aResult MsgBox "数据拆分完成！" End Sub

Sub Newbooks() EH技术论坛。VBA编程学习与实践。看见星光 Dim sht As Worksheet, mypath$ With Application.FileDialog(msoFileDialogFolderPicker) 选择保存工作薄的文件路径 .AllowMultiSelect = False 不允许多选 If .Show Then mypath = .SelectedItems(1) 读取选择的文件路径 Else Exit Sub 如果没有选择保存路径，则退出程序 End If End With If Right(mypath, 1) <> "\" Then mypath = mypath & "\" Application.DisplayAlerts = False 取消显示系统警告和消息，避免重名工作簿无法保存。当有重名工作簿时，会直接覆盖保存。 Application.ScreenUpdating = False 取消屏幕刷新 For Each sht In Worksheets 遍历工作表 sht.Copy 复制工作表，工作表单纯复制后，会成为活动工作薄 With ActiveWorkbook .SaveAs mypath & sht.Name, xlWorkbookDefault 保存活动工作薄到指定路径下，以默认文件格式 .Close True 关闭工作薄并保存 End With Next MsgBox "处理完成。", , "提醒" Application.ScreenUpdating = True 恢复屏幕刷新 Application.DisplayAlerts = True 恢复显示系统警告和消息 End Sub

Sub CollectSheets() ExcelHome VBA编程学习与实践 Dim sht As Worksheet, rng As Range, k&, trow&,temp Application.ScreenUpdating = False 取消屏幕更新，加快代码运行速度 temp = InputBox("请输入需要合并的工作表所包含的关键词：", "提醒") If StrPtr(temp) = 0 Then Exit Sub 如果点击了inputbox的取消或者关闭按钮，则退出程序 trow = Val(InputBox("请输入标题的行数", "提醒")) If trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub 取得用户输入的标题行数，如果为负数，退出程序 Cells.ClearContents 清空当前表数据 For Each sht In Worksheets 循环读取表格 If sht.Name <> ActiveSheet.Name Then 如果表格名称不等于当前表名则…… If InStr(1, sht.Name, temp, vbTextCompare) Then 如果表中包含关键词则进行汇总动作(不区分关键词字母大小写） Set rng = sht.UsedRange 定义rng为表格已用区域 k = k + 1 累计K值 If k = 1 Then 如果是首个表格，则K为1，则把标题行一起复制到汇总表 rng.Copy [a1].PasteSpecial Paste:=xlPasteValues Else 否则，扣除标题行后再复制黏贴到总表，只黏贴数值 rng.Offset(trow).Copy Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues End If End If End If Next [a1].Activate 激活A1单元格 Application.ScreenUpdating = True 恢复屏幕刷新 End Sub