达永编程网

程序员技术分享与交流平台

2025年06月12日

Excel常用技能分享与探讨(5-宏与VBA简介 VBA-实用自定义过程 二)

以下继续补充更多实用的VBA函数和子过程，每个功能都独立完整，包含详细说明和使用场景：

1. 工作日计算函数

' 功能：计算两个日期之间的工作日天数（排除周末）
' 参数：StartDate-开始日期, EndDate-结束日期
' 返回：工作日天数
Function WorkDays(StartDate As Date, EndDate As Date) As Integer
    Dim totalDays As Integer, currentDate As Date
    totalDays = 0
    
    For currentDate = StartDate To EndDate
        ' 周一至周五(1-5)为工作日
        If Weekday(currentDate, vbMonday) < 6 Then
            totalDays = totalDays + 1
        End If
    Next
    
    WorkDays = totalDays
End Function

使用场景：
项目计划、考勤计算、财务周期
工作表调用：
=WorkDays("2023-08-01", "2023-08-31") → 23天（假设8月有4个周末）

2. 数字转中文大写函数

' 功能：将阿拉伯数字转换为中文大写金额格式
' 参数：Number-数字金额
' 返回：中文大写字符串
Function NumberToChinese(Number As Double) As String
    Dim digits As Variant, units As Variant
    digits = Array("零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
    units = Array("", "拾", "佰", "仟", "万", "拾", "佰", "仟", "亿")
    
    Dim integerPart As String, decimalPart As String
    Dim result As String, i As Integer, digit As Integer
    
    ' 分离整数和小数部分
    integerPart = Left(Format(Number, "0.00"), InStr(Number, ".") - 1)
    decimalPart = Mid(Format(Number, "0.00"), InStr(Number, ".") + 1, 2)
    
    ' 转换整数部分
    For i = 1 To Len(integerPart)
        digit = Mid(integerPart, i, 1)
        result = result & digits(digit) & units(Len(integerPart) - i)
    Next
    
    ' 添加"元"
    If Len(integerPart) > 0 Then result = result & "元"
    
    ' 转换小数部分
    If decimalPart <> "00" Then
        result = result & digits(Left(decimalPart, 1)) & "角"
        result = result & digits(Right(decimalPart, 1)) & "分"
    Else
        result = result & "整"
    End If
    
    NumberToChinese = result
End Function

使用场景：
财务凭证、发票系统、合同金额
工作表调用：
=NumberToChinese(1234.56) → "壹仟贰佰叁拾肆元伍角陆分"

3. 公式转值工具

' 功能：将选定区域中的公式转换为静态值
Sub ConvertFormulasToValues()
    Dim rng As Range
    Set rng = Selection
    
    If MsgBox("将选定区域的公式转换为值吗？" & vbCrLf & _
              "区域大小: " & rng.Count & " 个单元格", _
              vbYesNo + vbQuestion, "确认操作") = vbNo Then Exit Sub
    
    rng.Copy
    rng.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    MsgBox "转换完成!"
End Sub

使用场景：
数据归档、报表定稿、性能优化
操作流程：

  1. 选择包含公式的区域
  2. 运行宏
  3. 确认转换（区域大小显示）

4. 多表查找替换工具

' 功能：在所有工作表中查找并替换内容
Sub FindReplaceAllSheets()
    Dim ws As Worksheet
    Dim findText As String, replaceText As String
    Dim count As Long
    
    findText = InputBox("输入要查找的内容", "查找")
    If findText = "" Then Exit Sub
    
    replaceText = InputBox("输入替换内容", "替换", findText)
    
    ' 遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        ws.Cells.Replace _
            What:=findText, _
            Replacement:=replaceText, _
            LookAt:=xlPart, _
            MatchCase:=False
        count = count + 1
    Next
    
    MsgBox "已在 " & count & " 个工作表中完成替换!", vbInformation
End Sub

使用场景：
批量更新产品名称、统一术语、修复拼写错误
特点：

  • 忽略大小写
  • 部分匹配替换
  • 显示处理的工作表数量

5. 提取字符串中的数字

' 功能：从文本中提取所有数字字符
' 参数：Text-包含数字的文本
' 返回：提取的数字字符串
Function ExtractNumbers(Text As String) As String
    Dim result As String, i As Integer, char As String
    
    For i = 1 To Len(Text)
        char = Mid(Text, i, 1)
        If char >= "0" And char <= "9" Then
            result = result & char
        End If
    Next
    
    ExtractNumbers = result
End Function

使用场景：
从混合文本中提取电话号码、产品编码、金额
工作表调用：
=ExtractNumbers("订单号: ABC-20230815-001") → "20230815001"

6. 按列拆分工作表

' 功能：根据指定列的值拆分数据到新工作簿
Sub SplitDataByColumn()
    Dim sourceSheet As Worksheet, newBook As Workbook
    Dim keyColumn As Integer, headerRow As Integer
    Dim lastRow As Long, i As Long
    Dim keyValue As String, prevValue As String
    
    Set sourceSheet = ActiveSheet
    keyColumn = Application.InputBox("输入拆分依据的列号", "列号", 1, Type:=1)
    headerRow = Application.InputBox("输入标题行号", "标题行", 1, Type:=1)
    
    ' 获取最后一行
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, keyColumn).End(xlUp).Row
    
    ' 按关键列排序
    sourceSheet.Sort.SortFields.Clear
    sourceSheet.Sort.SortFields.Add Key:=sourceSheet.Cells(1, keyColumn), Order:=xlAscending
    sourceSheet.Sort.SetRange sourceSheet.Range("A1:Z" & lastRow)
    sourceSheet.Sort.Header = xlYes
    sourceSheet.Sort.Apply
    
    ' 拆分数据
    prevValue = ""
    For i = headerRow + 1 To lastRow
        keyValue = sourceSheet.Cells(i, keyColumn).Value
        
        If keyValue <> prevValue Then
            ' 创建新工作簿
            Set newBook = Workbooks.Add
            ' 复制标题行
            sourceSheet.Rows(headerRow).Copy newBook.Sheets(1).Range("A1")
            prevValue = keyValue
        End If
        
        ' 复制数据行
        sourceSheet.Rows(i).Copy newBook.Sheets(1).Cells(newBook.Sheets(1).Rows.Count, 1).End(xlUp).Offset(1)
    Next
    
    MsgBox "数据拆分完成! 共创建 " & Workbooks.Count - 1 & " 个新工作簿", vbInformation
End Sub

使用场景：
按部门拆分报表、按地区分割销售数据、按类别整理产品
特点：

  • 自动排序数据
  • 保留标题行
  • 为每个唯一值创建独立工作簿

7. 公式检查函数

' 功能：检查单元格是否包含公式
' 参数：Cell-要检查的单元格
' 返回：TRUE(有公式)/FALSE(无公式)
Function HasFormula(Cell As Range) As Boolean
    HasFormula = Cell.HasFormula
End Function

使用场景：
审计跟踪、模板验证、错误检查
工作表调用：
=HasFormula(A1) → 如果A1包含公式返回TRUE

8. 工作表保护管理器

' 功能：批量保护或取消保护所有工作表
Sub ProtectAllSheets()
    Dim ws As Worksheet
    Dim password As String
    Dim action As Integer
    
    action = InputBox("选择操作:" & vbCrLf & "1 - 保护所有表" & vbCrLf & "2 - 取消保护", "工作表保护", 1)
    If action <> 1 And action <> 2 Then Exit Sub
    
    If action = 1 Then
        password = InputBox("输入保护密码", "密码设置")
    Else
        password = InputBox("输入当前密码", "密码验证")
    End If
    
    For Each ws In ThisWorkbook.Worksheets
        If action = 1 Then
            ws.Protect Password:=password, AllowFormattingCells:=True
        Else
            ws.Unprotect Password:=password
        End If
    Next
    
    MsgBox "操作完成! 已处理 " & ThisWorkbook.Sheets.Count & " 个工作表", vbInformation
End Sub

使用场景：
文档安全管理、报表分发、协作控制
特点：

  • 统一密码管理
  • 允许格式设置
  • 显示处理的工作表数量

9. 动态最大行号函数

' 功能：获取指定列的最后非空行号
' 参数：ColumnIndex-列索引(1=A列)
' 返回：最后非空行号
Function LastRowInColumn(ColumnIndex As Integer) As Long
    With ActiveSheet
        LastRowInColumn = .Cells(.Rows.Count, ColumnIndex).End(xlUp).Row
    End With
End Function

使用场景：
动态数据范围、自动填充、报表生成
工作表调用：
=LastRowInColumn(2) → 返回B列最后非空行号

10. 智能目录生成器

' 功能：创建包含所有工作表链接的目录页
Sub CreateSheetIndex()
    Dim ws As Worksheet, indexSheet As Worksheet
    Dim i As Integer
    
    ' 创建目录工作表
    Set indexSheet = Sheets.Add(Before:=Sheets(1))
    indexSheet.Name = "目录"
    
    ' 设置标题
    With indexSheet
        .Range("A1").Value = "工作表目录"
        .Range("A1").Font.Bold = True
        .Range("A1").Font.Size = 14
    End With
    
    ' 添加工作表链接
    i = 3
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "目录" Then
            ' 添加链接
            indexSheet.Hyperlinks.Add _
                Anchor:=indexSheet.Cells(i, 1), _
                Address:="", _
                SubAddress:="'" & ws.Name & "'!A1", _
                TextToDisplay:=ws.Name
            
            ' 添加描述
            indexSheet.Cells(i, 2).Value = "跳转到" & ws.Name
            
            i = i + 1
        End If
    Next
    
    ' 美化格式
    With indexSheet
        .Columns("A:B").AutoFit
        .Range("A3:A" & i).Font.Size = 11
        .Range("A1").EntireRow.RowHeight = 25
    End With
    
    MsgBox "目录已创建! 包含 " & i - 3 & " 个工作表链接", vbInformation
End Sub

使用场景：
大型工作簿导航、项目文档管理、多表报表
特点：

  • 自动排除目录页
  • 创建可点击的超链接
  • 自适应列宽
  • 显示工作表数量

使用指南：

函数(Function)使用方法：

  1. 在VBA编辑器中创建新模块
  2. 复制函数代码到模块
  3. 在工作表中像普通函数一样调用
=WorkDays(A1, B1) 
=NumberToChinese(C2)

子过程(Sub)使用方法：

  1. 在VBA编辑器中创建新模块
  2. 复制子过程代码到模块
  3. 通过以下方式执行：
  4. 按 Alt+F8 选择宏运行
  5. 绑定到按钮或快捷键
  6. 在VBA编辑器中按 F5

最佳实践：

  1. 关键操作前备份数据
  2. 为重要宏添加确认对话框
  3. 使用错误处理（如 On Error Resume Next）
  4. 为常用宏设置快捷键（开发工具 → 宏 → 选项）

这些功能涵盖了数据处理、文本转换、安全管理、导航优化等多种场景，可以根据实际需求组合使用或单独调用。每个功能都设计为独立完整，可直接复制到VBA模块中使用。

标签：vb编程代码大全可复制 

作者:dayon66 , 分类:技术文章 , 浏览:3 , 评论:0

控制面板
您好，欢迎到访网站！
  查看权限
网站分类
最新留言