Excel高手秘笈:不懂编程也能上手的5个VBA脚本,解决90%日常难题

Sub 合并所有工作表数据()    Dim ws As Worksheet    Dim 总表 As Worksheet    Dim 最后行 As Long    Dim 目标行 As Long    ' 创建新工作表存放汇总数据    Set 总表 = Worksheets.Add    总表.Name = "数据汇总"    ' 在总表设置标题（假设每个表第一行是标题）    Worksheets(1).Rows(1).Copy 总表.Rows(1)    目标行 = 2 ' 从第二行开始粘贴数据    ' 遍历除总表外的所有工作表    For Each ws In ThisWorkbook.Worksheets        If ws.Name <> "数据汇总" Then            最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row            If 最后行 > 1 Then ' 如果有数据（排除标题行）                ws.Range("A2:A" & 最后行).EntireRow.Copy _                    总表.Cells(目标行, 1)                目标行 = 目标行 + (最后行 - 1)            End If        End If    Next ws    ' 美化表格    总表.Columns.AutoFit    总表.Rows(1).Font.Bold = True    MsgBox "数据合并完成！共合并了 " & (目标行 - 2) & " 行数据。"End Sub

Sub 快速删除空行()    Dim rng As Range    Dim i As Long    ' 选择当前使用的数据区域    Set rng = ActiveSheet.UsedRange    ' 从下往上遍历，避免删除行导致索引错乱    For i = rng.Rows.Count To 1 Step -1        ' 如果整行都为空，则删除该行        If WorksheetFunction.CountA(rng.Rows(i)) = 0 Then            rng.Rows(i).Delete        End If    Next i    ' 清除完全空白的行（不在使用范围内但存在的空行）    On Error Resume Next    ActiveSheet.Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete    On Error GoTo 0    MsgBox "空行清理完成！"End Sub

Sub 批量重命名文件()    Dim 文件路径 As String    Dim 文件名 As String    Dim 新文件名 As String    Dim i As Integer    ' 选择文件夹    With Application.FileDialog(msoFileDialogFolderPicker)        .Title = "请选择要重命名文件的文件夹"        If .Show <> -1 Then Exit Sub        文件路径 = .SelectedItems(1)        If Right(文件路径, 1) <> "\" Then 文件路径 = 文件路径 & "\"    End With    文件名 = Dir(文件路径 & "*.xls*")    i = 1    Do While 文件名 <> ""        ' 构建新文件名（示例：添加序号前缀）        新文件名 = Format(i, "00") & "_" & 文件名        ' 重命名文件        Name 文件路径 & 文件名 As 文件路径 & 新文件名        ' 获取下一个文件名        文件名 = Dir        i = i + 1    Loop    MsgBox "重命名完成！共处理了 " & (i - 1) & " 个文件。"End Sub

Sub 按条件拆分工作表()    Dim 原始表 As Worksheet    Dim 新表 As Worksheet    Dim 最后行 As Long, 最后列 As Long    Dim i As Long, 当前行 As Long    Dim 拆分列 As Integer    Dim 分类值 As String    Dim 字典 As Object    Set 原始表 = ActiveSheet    最后行 = 原始表.Cells(原始表.Rows.Count, 1).End(xlUp).Row    最后列 = 原始表.Cells(1, 原始表.Columns.Count).End(xlToLeft).Column    ' 选择按哪一列拆分（例如：B列是省份）    拆分列 = 2 ' B列    Set 字典 = CreateObject("Scripting.Dictionary")    ' 收集所有不重复的分类值    For i = 2 To 最后行        分类值 = 原始表.Cells(i, 拆分列).Value        If Not 字典.Exists(分类值) Then            字典.Add 分类值, 分类值        End If    Next i    ' 为每个分类创建新工作表并复制数据    For Each 分类值 In 字典.Keys        ' 创建新工作表        Set 新表 = Worksheets.Add(After:=Worksheets(Worksheets.Count))        新表.Name = Left(分类值, 31) ' 工作表名最多31个字符        ' 复制标题行        原始表.Rows(1).Copy 新表.Rows(1)        当前行 = 2        For i = 2 To 最后行            If 原始表.Cells(i, 拆分列).Value = 分类值 Then                原始表.Rows(i).Copy 新表.Rows(当前行)                当前行 = 当前行 + 1            End If        Next i        ' 调整列宽        新表.Columns.AutoFit    Next    MsgBox "拆分完成！共创建了 " & 字典.Count & " 个工作表。"End Sub

Sub 生成工作表目录()    Dim 目录表 As Worksheet    Dim ws As Worksheet    Dim i As Integer    Dim 超链接公式 As String    ' 删除已存在的目录表    On Error Resume Next    Application.DisplayAlerts = False    Worksheets("目录").Delete    Application.DisplayAlerts = True    On Error GoTo 0    ' 在最前面创建目录表    Set 目录表 = Worksheets.Add(Before:=Worksheets(1))    目录表.Name = "目录"    ' 设置目录标题    With 目录表        .Cells(1, 1).Value = "序号"        .Cells(1, 2).Value = "工作表名称"        .Cells(1, 3).Value = "创建时间"        .Cells(1, 4).Value = "数据行数"        ' 美化标题        .Rows(1).Font.Bold = True        .Rows(1).Interior.Color = RGB(219, 229, 241)    End With    i = 2    For Each ws In ThisWorkbook.Worksheets        If ws.Name <> "目录" Then            ' 添加序号            目录表.Cells(i, 1).Value = i - 1            ' 添加带超链接的工作表名            目录表.Hyperlinks.Add _                Anchor:=目录表.Cells(i, 2), _                Address:="", _                SubAddress:="'" & ws.Name & "'!A1", _                TextToDisplay:=ws.Name            ' 添加工作表信息            目录表.Cells(i, 3).Value = ws.UsedRange.Rows.Count - 1            目录表.Cells(i, 4).Value = Format(Now(), "yyyy-mm-dd")            i = i + 1        End If    Next ws    ' 美化目录表    目录表.Columns.AutoFit    目录表.Cells.EntireColumn.AutoFit    MsgBox "目录生成完成！点击工作表名称可直接跳转。"End Sub