系统的学习了VBA之后，可以把一些重复的功能即成为一个函数过程，使用时直接调用即可。以下整理了一些实用的技巧，这些函数和子过程涵盖了文件操作、数据验证、地理计算、自动化任务等场景，可根据实际需求调整参数（如分隔符、保存路径等）。对于敏感操作，建议先在小范围测试后再全面使用。

一、实用函数(Function) - 可在工作表中直接调用

' 1. 十进制转二进制（指定位数）
Function DecToBin(ByVal Number As Long, Optional Bits As Integer = 8) As String
    If Number >= 2 ^ Bits Then DecToBin = "溢出": Exit Function
    Dim i As Integer, result As String
    For i = Bits - 1 To 0 Step -1
        result = result & IIf(Number And 2 ^ i, "1", "0")
    Next
    DecToBin = result
End Function

' 2. 提取分隔文本的指定部分
Function SplitText(ByVal Text As String, ByVal Delimiter As String, ByVal Index As Integer) As String
    Dim arr() As String
    arr = Split(Text, Delimiter)
    If Index > UBound(arr) + 1 Or Index < 1 Then SplitText = "" Else SplitText = arr(Index - 1)
End Function

' 3. 合并区域内容（自定义分隔符）
Function MergeRange(rng As Range, Optional Delimiter As String = ",") As String
    Dim cell As Range, result As String
    For Each cell In rng
        If cell.Value <> "" Then result = result & cell.Value & Delimiter
    Next
    If Len(result) > 0 Then result = Left(result, Len(result) - Len(Delimiter))
    MergeRange = result
End Function

' 4. 计算两个日期之间的工作日（排除周末）
Function WorkDays(StartDate As Date, EndDate As Date) As Integer
    Dim totalDays As Integer, i As Integer
    totalDays = 0
    For i = StartDate To EndDate
        If Weekday(i, vbMonday) < 6 Then totalDays = totalDays + 1
    Next
    WorkDays = totalDays
End Function

' 5. 中文数字转阿拉伯数字（简易版）
Function ChineseToNumber(ByVal str As String) As Long
    Dim dict As Object, i As Long, result As Long
    Set dict = CreateObject("Scripting.Dictionary")
    dict("一") = 1: dict("二") = 2: dict("三") = 3: dict("四") = 4: dict("五") = 5
    dict("六") = 6: dict("七") = 7: dict("八") = 8: dict("九") = 9: dict("十") = 10
    
    For i = 1 To Len(str)
        If dict.exists(Mid(str, i, 1)) Then result = result + dict(Mid(str, i, 1))
    Next
    ChineseToNumber = result
End Function

' 6. 提取文件路径中的文件名（无扩展名）
Function ExtractFileName(fullPath As String) As String
    Dim fileName As String
    fileName = Mid(fullPath, InStrRev(fullPath, "\") + 1)
    ExtractFileName = Left(fileName, InStrRev(fileName, ".") - 1)
End Function

' 7. 验证电子邮件格式
Function IsValidEmail(email As String) As Boolean
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^[\w-\.]+@([\w-]+\.)+[\w-]{2,4}#34;
    IsValidEmail = regex.Test(email)
End Function

' 8. 生成指定范围的随机密码
Function GeneratePassword(Optional length As Integer = 8) As String
    Const chars As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*"
    Dim i As Integer, result As String
    Randomize
    For i = 1 To length
        result = result & Mid(chars, Int(Rnd * Len(chars)) + 1, 1)
    Next
    GeneratePassword = result
End Function

' 9. 将秒数转换为时分秒格式
Function SecondsToHMS(totalSeconds As Long) As String
    Dim hours As Long, minutes As Long, seconds As Long
    hours = totalSeconds \ 3600
    minutes = (totalSeconds Mod 3600) \ 60
    seconds = totalSeconds Mod 60
    SecondsToHMS = Format(hours, "00") & ":" & Format(minutes, "00") & ":" & Format(seconds, "00")
End Function

二、实用子过程(Sub) - 通过宏运行

' 1. 隔行填充数据（核心需求）
Sub FillAlternateRows()
    Dim rng As Range, cell As Range, startRow As Integer, fillValue As String
    Set rng = Application.InputBox("选择填充区域", "隔行填充", Type:=8)
    If rng Is Nothing Then Exit Sub
    
    fillValue = InputBox("输入填充内容", "填充内容", "数据")
    startRow = IIf(InputBox("起始行：1-奇数行, 2-偶数行", "起始行", 1) = 1, 1, 2)
    
    For Each cell In rng
        If (cell.Row - rng.Row + startRow) Mod 2 = 1 Then cell.Value = fillValue
    Next
    MsgBox "隔行填充完成！"
End Sub

' 2. 自定义插入行
Sub InsertCustomRows()
    Dim rowCount As Integer, targetRow As Long
    rowCount = Application.InputBox("输入插入行数", "插入行", 1, Type:=1)
    If rowCount < 1 Then Exit Sub
    
    targetRow = Selection.Row
    Rows(targetRow & ":" & targetRow + rowCount - 1).Insert Shift:=xlDown
End Sub

' 3. 自定义插入列
Sub InsertCustomColumns()
    Dim colCount As Integer, targetCol As Long
    colCount = Application.InputBox("输入插入列数", "插入列", 1, Type:=1)
    If colCount < 1 Then Exit Sub
    
    targetCol = Selection.Column
    Columns(targetCol & ":" & targetCol + colCount - 1).Insert Shift:=xlRight
End Sub

' 4. 快速删除空行
Sub DeleteEmptyRows()
    On Error Resume Next
    Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    MsgBox "空行已删除！"
End Sub

' 5. 批量重命名工作表
Sub BatchRenameSheets()
    Dim prefix As String, i As Integer
    prefix = InputBox("输入工作表名前缀", "批量重命名", "Sheet_")
    
    For i = 1 To Worksheets.Count
        Worksheets(i).Name = prefix & i
    Next
    MsgBox "已重命名 " & i - 1 & " 个工作表！"
End Sub

' 6. 智能调整列宽（基于内容）
Sub AutoFitColumns()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Cells.EntireColumn.AutoFit
    MsgBox "列宽已自动调整！"
End Sub

' 7. 跨表数据收集
Sub CollectDataFromSheets()
    Dim masterSheet As Worksheet, dataSheet As Worksheet
    Dim lastRow As Long, destRow As Long
    
    Set masterSheet = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    masterSheet.Name = "汇总数据"
    destRow = 1
    
    For Each dataSheet In ThisWorkbook.Sheets
        If dataSheet.Name <> masterSheet.Name Then
            lastRow = dataSheet.Cells(Rows.Count, 1).End(xlUp).Row
            dataSheet.Range("A1:Z" & lastRow).Copy masterSheet.Cells(destRow, 1)
            destRow = destRow + lastRow
        End If
    Next
    MsgBox "数据收集完成！共汇总 " & destRow - 1 & " 行数据"
End Sub

' 8. 批量重命名文件
Sub BatchRenameFiles()
    Dim folderPath As String, newName As String, prefix As String
    Dim i As Integer, fileName As String, fileExt As String
    Dim fso As Object, folder As Object, file As Object
    
    folderPath = InputBox("输入文件夹路径", "批量重命名", "C:\YourFolder\")
    If folderPath = "" Then Exit Sub
    prefix = InputBox("输入新文件名前缀", "文件名前缀", "File_")
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    i = 1
    
    For Each file In folder.Files
        fileExt = fso.GetExtensionName(file.Name)
        newName = prefix & Format(i, "000") & "." & fileExt
        file.Name = newName
        i = i + 1
    Next
    
    MsgBox "已重命名 " & i - 1 & " 个文件!"
End Sub

' 9. 数据透视表自动创建
Sub CreatePivotTable()
    Dim ws As Worksheet, ptCache As PivotCache, pt As PivotTable
    Dim dataRange As Range, destRange As Range
    
    ' 设置数据源和目标位置
    Set ws = ActiveSheet
    Set dataRange = ws.UsedRange
    Set destRange = ws.Cells(dataRange.Rows.Count + 3, 1)
    
    ' 创建透视表
    Set ptCache = ThisWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=dataRange)
    
    Set pt = ptCache.CreatePivotTable( _
        TableDestination:=destRange, _
        TableName:="SummaryPivot")
    
    ' 配置透视表字段
    With pt
        .PivotFields("类别").Orientation = xlRowField
        .PivotFields("地区").Orientation = xlColumnField
        .PivotFields("销售额").Orientation = xlDataField
        .DataPivotField.Function = xlSum
    End With
    
    MsgBox "数据透视表创建完成!"
End Sub

' 10. 批量导出图表为图片
Sub ExportChartsAsImages()
    Dim ws As Worksheet, chartObj As ChartObject
    Dim folderPath As String, i As Integer
    
    folderPath = InputBox("输入保存路径", "导出图表", "C:\ChartExports\")
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    On Error Resume Next
    MkDir folderPath
    On Error GoTo 0
    
    i = 0
    For Each ws In ThisWorkbook.Worksheets
        For Each chartObj In ws.ChartObjects
            chartObj.Chart.Export folderPath & ws.Name & "_Chart" & i & ".png", "PNG"
            i = i + 1
        Next
    Next
    
    MsgBox "成功导出 " & i & " 个图表!"
End Sub

' 11. 智能数据分列（自动识别分隔符）
Sub SmartTextToColumns()
    Dim rng As Range, cell As Range
    Dim commonDelimiters As Variant
    Dim delimiter As String, maxCount As Integer, count As Integer, i As Integer
    
    Set rng = Selection
    commonDelimiters = Array(",", ";", "|", vbTab, " ")
    
    ' 自动检测最可能的分隔符
    For Each cell In rng.Cells(1).Resize(10)
        For i = 0 To UBound(commonDelimiters)
            count = Len(cell.Value) - Len(Replace(cell.Value, commonDelimiters(i), ""))
            If count > maxCount Then
                maxCount = count
                delimiter = commonDelimiters(i)
            End If
        Next
    Next
    
    If delimiter = "" Then delimiter = InputBox("未检测到分隔符，请手动输入", "分隔符", ",")
    
    ' 执行分列操作
    rng.TextToColumns Destination:=rng.Cells(1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
        Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
        Other:=True, OtherChar:=delimiter
        
    MsgBox "已完成分列操作，使用分隔符: " & IIf(delimiter = vbTab, "[Tab]", delimiter)
End Sub

' 12. 数据完整性检查（查找空单元格）
Sub CheckDataIntegrity()
    Dim ws As Worksheet, rng As Range, emptyCells As Range
    Dim col As Integer, result As String
    
    Set ws = ActiveSheet
    result = "数据完整性检查结果:" & vbCrLf & vbCrLf
    
    For col = 1 To ws.UsedRange.Columns.Count
        On Error Resume Next
        Set emptyCells = ws.Columns(col).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0
        
        If Not emptyCells Is Nothing Then
            result = result & "列 " & Split(ws.Cells(1, col).Address(False, False), "#34;)(0) & _
                     ": 发现 " & emptyCells.Count & " 个空单元格" & vbCrLf
            emptyCells.Interior.Color = RGB(255, 255, 0) ' 标记为黄色
            Set emptyCells = Nothing
        End If
    Next
    
    MsgBox result & vbCrLf & "空单元格已标记为黄色", vbInformation, "数据检查"
End Sub

' 13. 定时保存工作簿
Sub AutoSaveWithTimestamp()
    Dim savePath As String, fileName As String
    savePath = ThisWorkbook.Path & "\Backups\"
    fileName = Replace(ThisWorkbook.Name, ".xlsm", "") & "_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsm"
    
    On Error Resume Next
    MkDir savePath
    On Error GoTo 0
    
    ThisWorkbook.SaveCopyAs savePath & fileName
    MsgBox "工作簿已备份为: " & fileName, vbInformation, "自动备份"
End Sub

3、使用说明：

• 函数使用：

在工作表单元格中直接调用，如 =DecToBin(15, 8)

示例：=SplitText(A1, "-", 2) 拆分A1单元格内容

• 子过程使用：

按 Alt+F8 打开宏窗口

选择要运行的宏（如"FillAlternateRows"）

点击"执行"按钮

• 隔行填充说明：

运行"FillAlternateRows"宏

选择要填充的区域

输入填充内容（如"奇数行"）

选择起始行类型（1=奇数行，2=偶数行）

• 推荐操作：

将常用宏添加到快速访问工具栏

使用快捷键绑定（开发工具 → 宏 → 选项 → 设置快捷键）

提示：使用前请备份数据，部分操作（如删除空行）不可撤销。可通过修改代码中的参数（如分隔符、起始行设置等）适应具体需求。

函数使用示例：

=ExtractFileName("C:\Reports\Q3_Summary.xlsx")  → 返回 "Q3_Summary"
=IsValidEmail("test@example.com")              → 返回 TRUE
=DistanceBetweenPoints(40.7128, -74.0060, 34.0522, -118.2437) → 约3940000米
=GeneratePassword(12)                          → 随机生成12位密码

子过程使用技巧：

• 定时保存工作簿：可绑定到按钮或通过Application.OnTime定时调用
• 智能分列：自动识别最常见分隔符，减少手动配置
• 数据完整性检查：快速定位缺失数据点

推荐实践：

1. 将常用宏添加到快速访问工具栏
2. 为复杂操作创建用户窗体(UserForm)提供更好界面
3. 使用错误处理(On Error Resume Next)避免意外中断
4. 对关键操作添加确认对话框，防止误操作