Excel VBA 宏 - 自动创建表格
应朋友的需求，编写了一个 VBA 宏，用于自动创建工作簿，实现了排版布局、冻结表头、条件格式、自动求和、单元格保护等功能。
分别创建了 4 个工作簿 1-12月流水帐+库存表、1-12月银行现金日记账、1-12月商品进货单、单一帐目表，用于小公司记账比较方便。
Sub Main()
Call 创建流水账("商品销售流水账_自动创建")
Call 创建日记账("银行现金日记账_自动创建")
Call 创建进货单("某某商品进货单_自动创建")
Call 创建单表("某某帐目_自动创建", "某某帐目")
End Sub
' 创建流水账表格
' name = 文件名
Sub 创建流水账(name As String)
' 创建工作薄（可能会创建在当前目录或“我的文档”目录）
Dim wb As Workbook
Set wb = NewWorkbook(".\" & name)
' 只保留一个工作表
Dim ws As Worksheet
Set ws = ClearSheets(wb)
' 设置所有单元格格式
With Cells
.RowHeight = 30 ' 设置行高
.Font.Size = 12 ' 设置字体
.HorizontalAlignment = xlCenter ' 水平居中
.VerticalAlignment = xlCenter ' 竖直居中
.WrapText = True ' 自动换行
End With
' 绘制表格
Call DrawTable(ws, "A1", "2023 年 1 月商品销售表", "日期 名称 成本价 成交价 毛利润 备注", "9 28 12 12 12 30", 500)
' 绘制表格
Call DrawTable(ws, "H1", "2023 年 1 月经营费用表", "日期 收支 备注", "9 12 30", 500)
' 表格之间的间距
Columns(7).ColumnWidth = 1
' 设置单元格格式
Call DateFormat(Range("A4:A500")) ' 日期格式，居中
Call DateFormat(Range("H4:H500")) ' 日期格式，居中
Call TextFormat(Range("B4:B500"), False) ' 文本格式，不居中
Call TextFormat(Range("F4:F500"), False) ' 文本格式，不居中
Call TextFormat(Range("J4:J500"), False) ' 文本格式，不居中
Call NamedNumFormat(Range("B2"), "平均利润") ' 带前缀数值格式，居中
' 填写公式
Range("B2").Value = "=(E2+I2)/2" ' 平均利润，总利润除以合伙人数量，这里除以 2
Range("C2:E2").Value = "=SUM(C4:C500)" ' 成本/成交/利润
Range("I2").Value = "=SUM(I4:I500)" ' 收支
Range("E5:E500").Value = "=D5-C5" ' 收支
' 设置公式结果为粗体
FormulasCells(ws).Font.Bold = True
' 设置公式单元格颜色（锁定状态的颜色，亮色）
Call LightBGColor(FormulasCells(ws))
' 设置条件格式
Call FormatCondition(Range("B2"), False, False, True) ' 平均利润
Call FormatCondition(Range("C2:D2"), False, True, True) ' 成本/成交
Call FormatCondition(Range("C4:D500"), False, True, False) ' 成本/成交
Call FormatCondition(Range("E2"), True, False, True) ' 利润
Call FormatCondition(Range("E4:E500"), True, False, True) ' 利润
Call FormatCondition(Range("I2"), True, False, True) ' 收支
Call FormatCondition(Range("I4:I500"), True, False, True) ' 收支
' 冻结表格
Call FreezeTable(Range("A4"))
' 取消锁定（用户可编辑区域）
Call UnLockCell(Range("A1:F1"))
Call UnLockCell(Range("H1:J1"))
Call UnLockCell(Range("F2"))
Call UnLockCell(Range("J2"))
Call UnLockCell(Range("A5:D500"))
Call UnLockCell(Range("F5:F500"))
Call UnLockCell(Range("H5:J500"))
' 保护工作表
Call ProtectSheet(ws, "123")
' 复制出 12 个月的工作表
ws.name = "1月"
For i = 2 To 12
ws.Copy After:=ws ' 拷贝当前工作表到其之后的位置
Set ws = wb.ActiveSheet ' 设置新工作表为当前工作表
ws.name = i & "月" ' 修改工作表标签名
' 修改表格标题
ws.Range("A1").Value = "2023 年 " & i & " 月商品销售表"
ws.Range("H1").Value = "2023 年 " & i & " 月经营费用表"
Next
' 创建库存表
Sheets.Add After:=ws ' 添加新工作表
Set ws = wb.ActiveSheet ' 设置新工作表为当前工作表
ws.name = "库存"
' 设置所有单元格格式
With Cells
.RowHeight = 30 ' 设置行高
.Font.Size = 12 ' 设置字体
.HorizontalAlignment = xlCenter ' 水平居中
.VerticalAlignment = xlCenter ' 竖直居中
.WrapText = True ' 自动换行
End With
' 绘制表格（库存表）
Call DrawTable(ws, "A1", "2023 年商品库存表", "日期 名称 成本 备注", "9 50 16 50", 500)
' 设置单元格格式
Call DateFormat(Range("A4:A500")) ' 日期格式，居中
Call TextFormat(Range("B4:B500"), False) ' 文本格式，不居中
Call TextFormat(Range("D4:D500"), False) ' 文本格式，不居中
' 填写公式
Range("C2").Value = "=SUM(C4:C500)"
' 设置公式结果为粗体
FormulasCells(ws).Font.Bold = True
' 设置公式单元格颜色（锁定状态的颜色，亮色）
Call LightBGColor(FormulasCells(ws))
' 设置条件格式
Call FormatCondition(Range("C2"), True, False, True) ' 成本
Call FormatCondition(Range("C4:C500"), True, False, True) ' 成本
' 冻结表格
Call FreezeTable(Range("A4"))
' 取消锁定（用户可编辑区域）
Call UnLockCell(Range("A1:D1"))
Call UnLockCell(Range("B2"))
Call UnLockCell(Range("D2"))
Call UnLockCell(Range("A5:D500"))
' 保护工作表
Call ProtectSheet(ws, "123")
' 激活 1 月工作表
wb.Sheets(1).Activate
' 保存工作表
Call SaveWorkbook(wb)
Call CloseWorkbook(wb)
End Sub
' 创建日记账表格
' name = 文件名
Sub 创建日记账(name As String)
' 创建工作薄（可能会创建在当前目录或“我的文档”目录）
Dim wb As Workbook
Set wb = NewWorkbook(".\" & name)
' 只保留一个工作表
Dim ws As Worksheet
Set ws = ClearSheets(wb)
' 设置所有单元格格式
With Cells
.RowHeight = 30 ' 设置行高
.Font.Size = 12 ' 设置字体
.HorizontalAlignment = xlCenter ' 水平居中
.VerticalAlignment = xlCenter ' 竖直居中
.WrapText = True ' 自动换行
End With
' 绘制表格
Call DrawTable(ws, "A1", "2023 年 1 月银行日记账", "日期 凭证号 收入 支出 余额 备注", "9 13 12 12 12 18", 500)
Call RedBGColor(Range("A1")) ' 表头红色
' 绘制表格
Call DrawTable(ws, "H1", "2023 年 1 月现金日记账", "日期 凭证号 收入 支出 余额 备注", "9 13 12 12 12 18", 500)
Call OrangeBGColor(Range("H1")) ' 表头橙色
' 表格之间的间距
Columns(7).ColumnWidth = 1
' 设置单元格格式
Call DateFormat(Range("A4:A500")) ' 日期格式，居中
Call DateFormat(Range("H4:H500")) ' 日期格式，居中
Call TextFormat(Range("B4:B500"), True) ' 文本格式，居中
Call TextFormat(Range("I4:I500"), True) ' 文本格式，居中
Call NumFormat(Range("C4:E500"), False) ' 数值格式，居中
Call NumFormat(Range("J4:L500"), False) ' 数值格式，居中
Call TextFormat(Range("F4:F500"), False) ' 文本格式，不居中
Call TextFormat(Range("M4:M500"), False) ' 文本格式，不居中
' 填写公式
Range("C2:E2").Value = "=SUM(C4:C500)" ' 收入/支出/余额
Range("J2:L2").Value = "=SUM(J4:J500)" ' 收入/支出/余额
Range("E5:E500").Value = "=C5-D5" ' 余额
Range("L5:L500").Value = "=J5-K5" ' 余额
' 设置公式结果为粗体
FormulasCells(ws).Font.Bold = True
' 设置公式单元格颜色（锁定状态的颜色，亮色）
Call LightBGColor(FormulasCells(ws))
' 设置条件格式
Call FormatCondition(Range("C2:D2"), False, True, True) ' 收入/支出（不可为负）
Call FormatCondition(Range("E2"), True, False, True) ' 收入/支出（负数红色，零无色）
Call FormatCondition(Range("C4:D500"), False, True, False) ' 收入/支出（不可为负）
Call FormatCondition(Range("E4:E500"), True, False, True) ' 收入/支出（负数红色，零无色）
Call FormatCondition(Range("J2:K2"), False, True, True) ' 收入/支出（不可为负）
Call FormatCondition(Range("L2"), True, False, True) ' 收入/支出（负数红色，零无色）
Call FormatCondition(Range("J4:L500"), False, True, False) ' 收入/支出（不可为负）
Call FormatCondition(Range("L4:L500"), True, False, True) ' 收入/支出（负数红色，零无色）
' 冻结表格
Call FreezeTable(Range("A4"))
' 取消锁定（用户可编辑区域）
Call UnLockCell(Range("A1:F1"))
Call UnLockCell(Range("H1:M1"))
Call UnLockCell(Range("B2"))
Call UnLockCell(Range("F2"))
Call UnLockCell(Range("I2"))
Call UnLockCell(Range("M2"))
Call UnLockCell(Range("A5:D500"))
Call UnLockCell(Range("F5:F500"))
Call UnLockCell(Range("H5:K500"))
Call UnLockCell(Range("M5:M500"))
' 保护工作表
Call ProtectSheet(ws, "123")
' 复制出 12 个月的工作表
ws.name = "1月"
For i = 2 To 12
ws.Copy After:=ws ' 拷贝当前工作表到其之后的位置
Set ws = wb.ActiveSheet ' 设置新工作表为当前工作表
ws.name = i & "月" ' 修改工作表标签名
' 修改表格标题
ws.Range("A1").Value = "2023 年 " & i & " 月银行日记账"
ws.Range("H1").Value = "2023 年 " & i & " 月现金日记账"
Next
' 激活 1 月工作表
wb.Sheets(1).Activate
' 保存工作表
Call SaveWorkbook(wb)
Call CloseWorkbook(wb)
End Sub
' 创建进货单表格（生成后，可以通过修改最后一个表格中的参数来更新所有表格的标题）
' name = 文件名
Sub 创建进货单(name As String)
' 创建工作薄（可能会创建在当前目录或“我的文档”目录）
Dim wb As Workbook
Set wb = NewWorkbook(name)
' 只保留一个工作表
Dim ws As Worksheet
Set ws = ClearSheets(wb)
' 设置所有单元格格式
With ws.Cells
.RowHeight = 30 ' 设置行高
.Font.Size = 12 ' 设置字体
.HorizontalAlignment = xlCenter ' 水平居中
.VerticalAlignment = xlCenter ' 竖直居中
.WrapText = True ' 自动换行
End With
' 绘制表格
Call DrawTable(ws, "A1", "2023 年 1 月某某商品进货单", "日期 编号 金额 备注", "9 26 12 50", 500)
' 设置单元格格式
Call DateFormat(Range("A4:A500")) ' 日期格式
Call TextFormat(Range("B4:B500"), True) ' 文本格式，居中
Call TextFormat(Range("D4:D500"), False) ' 文本格式，不居中
' 填写公式
Range("C2").Value = "=SUM(C4:C500)"
' 设置公式结果为粗体
FormulasCells(ws).Font.Bold = True
' 设置公式单元格颜色（锁定状态的颜色，亮色）
Call LightBGColor(FormulasCells(ws))
' 设置条件格式
Call FormatCondition(Range("C4:C500"), True, False, False) ' 小于 0 红色文本
Call FormatCondition(Range("C2"), True, False, True) ' 小于 0 红色文本，等于 0 无颜色
' 冻结表格
Call FreezeTable(Range("A4"))
' 取消锁定（用户可编辑区域）
Call UnLockCell(Range("B2"))
Call UnLockCell(Range("D2"))
Call UnLockCell(Range("A5:D500"))
' 复制出 12 个月的工作表
ws.name = "1月"
For i = 2 To 12
ws.Copy After:=ws ' 拷贝当前工作表到其之后的位置
Set ws = wb.ActiveSheet ' 设置新工作表为当前工作表
ws.name = i & "月" ' 修改工作表标签名
Next
' 创建参数表
wb.Sheets.Add After:=ws
Set ws = wb.ActiveSheet
ws.name = "参数"
' 设置参数表的所有单元格格式
With ws.Cells
.RowHeight = 30 ' 设置行高
.Font.Size = 12 ' 设置字体
.HorizontalAlignment = xlCenter ' 水平居中
.VerticalAlignment = xlCenter ' 竖直居中
.WrapText = True ' 自动换行
End With
' 设置参数表的列宽
ws.Range("A1").ColumnWidth = 12
ws.Range("B1").ColumnWidth = 36
' 设置参数表内容
ws.Range("A1:B1").Merge
ws.Range("A1") = "工作表参数"
ws.Range("A2") = "表格标题"
ws.Range("B2") = "某某商品进货单"
ws.Range("B2").Locked = False
' 设置字体
ws.Range("A1").Font.Size = 18
ws.Range("A1").Font.Bold = True
ws.Range("A2").Font.Bold = True
' 设置参数表边框
Call SetBorders(ws.Range("A1:B1"), xlThin, xlMedium)
Call SetBorders(ws.Range("A2:B2"), xlThin, xlMedium)
' 设置参数表背景色
Call BlueBGColor(ws.Range("A1:B1"))
Call LightBGColor(ws.Range("A2"))
' 保护工作表
Call ProtectSheet(ws, "123")
' 设置工作表标题
For i = 1 To 12
Sheets(i).Range("A1").Value = "=""2023 年 " & i & " 月"" & 参数!B2"
' 保护工作表
Call ProtectSheet(Sheets(i), "123")
Next
' 激活 3 月工作表
wb.Sheets(3).Activate
' 保存工作表
Call SaveWorkbook(wb)
Call CloseWorkbook(wb)
End Sub
' 创建单表
' name = 文件名
' title = 表格标题
Sub 创建单表(name As String, title As String)
' 创建工作薄（可能会创建在当前目录或“我的文档”目录）
Dim wb As Workbook
Set wb = NewWorkbook(name)
' 只保留一个工作表
Dim ws As Worksheet
Set ws = ClearSheets(wb)
' 设置所有单元格格式
With Cells
.RowHeight = 30 ' 设置行高
.Font.Size = 12 ' 设置字体
.HorizontalAlignment = xlCenter ' 水平居中
.VerticalAlignment = xlCenter ' 竖直居中
.WrapText = True ' 自动换行
End With
' 绘制表格
Call DrawTable(ws, "A1", title, "日期 名称 金额 备注", "9 35 12 50", 500)
' 设置单元格格式
Call DateFormat(Range("A4:A500")) ' 日期格式，居中
Call TextFormat(Range("B4:B500"), False) ' 文本格式，不居中
Call TextFormat(Range("D4:D500"), False) ' 文本格式，不居中
' 填写公式
Range("C2").Value = "=SUM(C4:C500)"
' 设置公式结果为粗体
FormulasCells(ws).Font.Bold = True
' 设置公式单元格颜色（锁定状态的颜色，亮色）
Call LightBGColor(FormulasCells(ws))
' 设置条件格式
Call FormatCondition(Range("C2"), True, False, True) ' 小于 0 红色文本，等于 0 无颜色
Call FormatCondition(Range("C4:C500"), True, False, False) ' 小于 0 红色文本
' 冻结表格
Call FreezeTable(Range("A4"))
' 取消锁定（用户可编辑区域）
Call UnLockCell(Range("A1:D1"))
Call UnLockCell(Range("B2"))
Call UnLockCell(Range("D2"))
Call UnLockCell(Range("A5:D500"))
' 保护工作表
Call ProtectSheet(ws, "123")
' 设置工作表名称
ws.name = title
' 保存工作表
Call SaveWorkbook(wb)
Call CloseWorkbook(wb)
End Sub
' 绘制表格
Sub DrawTable(ws As Worksheet, starts As String, title As String, fields As String, widths As String, rows As Integer)
' 将字段列表分割为数组
Dim fieldList() As String
fieldList() = Split(fields)
Dim widthList() As String
widthList() = Split(widths)
' 获取字段数
Dim cols As Integer
cols = UBound(fieldList) - LBound(fieldList) + 1
' 合并单元格（标题）
Dim rg As Range
Set rg = Range(starts, Range(starts).Offset(0, cols - 1))
Call MergeCells(rg)
rg.Font.Size = 18 ' 设置字号
Set rg = Range(starts)
rg.Value = title ' 设置标题
rg.Font.Bold = True ' 设置粗体
' 合计
Set rg = Range(starts).Offset(1, 0)
With rg
.Value = "合计" ' 文本
.Font.Bold = True ' 加粗
End With
' 表头
Set rg = Range(starts).Offset(2, 0)
For i = LBound(fieldList) To UBound(fieldList)
Columns(i - LBound(fieldList) + rg.Column).ColumnWidth = Val(widthList(i))
With rg.Offset(0, i - LBound(fieldList))
.Value = fieldList(i) ' 文本
.Font.Bold = True ' 加粗
End With
Next
' 绘制网格
Set rg = Range(starts).Offset(1, 0)
Set rg = Range(rg, rg.Offset(0, cols - 1))
Call SetBorders(rg, xlThin, xlMedium)
Set rg = Range(starts).Offset(2, 0)
Set rg = Range(rg, rg.Offset(rows - 3, cols - 1))
Call SetBorders(rg, xlThin, xlMedium)
' 标题背景色
Set rg = Range(starts)
Call BlueBGColor(rg) ' 蓝色
' 设置单元格颜色（锁定状态的颜色，亮色）
Set rg = Range(starts).Offset(1, 0)
Call LightBGColor(rg) ' 亮色
Set rg = Range(starts).Offset(2, 0)
Set rg = Range(rg, rg.Offset(0, cols - 1))
Call LightBGColor(rg) ' 亮色
' 数据首行背景色（便于用户查看当前是否滚动到了行首）
Set rg = Range(starts).Offset(3, 0)
Set rg = Range(rg, rg.Offset(0, cols - 1))
Call TeaBGColor(rg) ' 茶色
End Sub
' 创建工作簿，并通过函数返回
Function NewWorkbook(name As String) As Workbook
Set NewWorkbook = Workbooks.Add ' 创建工作簿
Application.DisplayAlerts = False ' 禁用文件覆盖警告
NewWorkbook.SaveAs Filename:=name ' 保存文件
Application.DisplayAlerts = True ' 恢复文件覆盖警告
End Function
' 打开工作薄，并通过函数返回
Function OpenWorkbook(name As String) As Workbook
Set OpenWorkbook = Workbooks.Open(name) ' 打开工作薄
End Function
' 保存工作薄
Sub SaveWorkbook(wb As Workbook)
wb.Save
End Sub
' 关闭工作薄
Sub CloseWorkbook(wb As Workbook)
wb.Close
End Sub
' 删除多余工作表，只保留第一张工作表
Function ClearSheets(wb As Workbook) As Worksheet
Application.DisplayAlerts = False ' 禁用删除确认
For i = wb.Worksheets.Count To 2 Step -1 ' 循环删除工作表
wb.Worksheets(i).Delete
Next
Application.DisplayAlerts = True ' 恢复删除确认
Set ClearSheets = wb.Worksheets(1) ' 返回第一张工作表
End Function
' 合并单元格
Sub MergeCells(rg As Range)
rg.MergeCells = True
End Sub
' 设置表格线框
Sub SetBorders(rg As Range, innerWeight As Variant, outerWeight As Variant)
rg.Borders(xlDiagonalDown).LineStyle = xlNone ' 取消斜边样式
rg.Borders(xlDiagonalUp).LineStyle = xlNone ' 取消斜边样式
With rg.Borders
.LineStyle = xlContinuous ' 线型
.ColorIndex = 0 ' 颜色
.TintAndShade = 0 ' 色调和阴影
.Weight = innerWeight ' 线宽
End With
With rg.Borders(xlEdgeLeft) ' 整体左
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = outerWeight
End With
With rg.Borders(xlEdgeTop) ' 整体左
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = outerWeight
End With
With rg.Borders(xlEdgeBottom) ' 整体左
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = outerWeight
End With
With rg.Borders(xlEdgeRight) ' 整体左
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = outerWeight
End With
End Sub
' 设置表格背景色
'
' color 指定颜色值，取值：
' xlThemeColorDark1 白色
' xlThemeColorLight1 黑色
' xlThemeColorDark2 茶色
' xlThemeColorLight2 深蓝色
' xlThemeColorAccent1 蓝色
' xlThemeColorAccent2 红色
' xlThemeColorAccent3 橄榄色
' xlThemeColorAccent4 紫色
' xlThemeColorAccent5 水绿色
' xlThemeColorAccent6 橙色
'
' tint 指定亮度百分比（取值范围在 1 到 -1 之间）
' 一般取值为：正负 0.8、0.6、0.5、0.4、0.35、0.25、0.15、0.05、0
Sub SetBGColor(rg As Range, color As Variant, tint As Double)
With rg.Interior
.Pattern = xlSolid ' 图案类型
.PatternColorIndex = xlAutomatic ' 图案样式
.PatternTintAndShade = 0 ' 图案的色调与阴影
.ThemeColor = color ' 颜色
.TintAndShade = tint ' 色调与阴影
End With
End Sub
' 设置亮色背景（-0.05 -0.25 -0.35 -0.45 -0.5）
Sub LightBGColor(rg As Range, Optional tint As Double = -0.05)
Call SetBGColor(rg, xlThemeColorDark1, tint)
End Sub
' 设置暗色背景（0.5 0.35 0.25 0.15 0.05）
Sub DarkBGColor(rg As Range, Optional tint As Double = 0.5)
Call SetBGColor(rg, xlThemeColorLight1, tint)
End Sub
' 设置茶色背景（-0.1 -0.25 -0.5 -0.75 -0.9）
Sub TeaBGColor(rg As Range, Optional tint As Double = 0)
Call SetBGColor(rg, xlThemeColorDark2, tint)
End Sub
' 设置深蓝色背景（0.8 0.6 0.4 -0.25 -0.5）
Sub DarkBlueBGColor(rg As Range, Optional tint As Double = 0.8)
Call SetBGColor(rg, xlThemeColorLight2, tint)
End Sub
' 设置蓝色背景（0.8 0.6 0.4 -0.25 -0.5）
Sub BlueBGColor(rg As Range, Optional tint As Double = 0.6)
Call SetBGColor(rg, xlThemeColorAccent1, tint)
End Sub
' 设置红色背景（0.8 0.6 0.4 -0.25 -0.5）
Sub RedBGColor(rg As Range, Optional tint As Double = 0.6)
Call SetBGColor(rg, xlThemeColorAccent2, tint)
End Sub
' 设置橄榄色背景（0.8 0.6 0.4 -0.25 -0.5）
Sub GreenBGColor(rg As Range, Optional tint As Double = 0.6)
Call SetBGColor(rg, xlThemeColorAccent3, tint)
End Sub
' 设置紫色背景（0.8 0.6 0.4 -0.25 -0.5）
Sub PurpleBGColor(rg As Range, Optional tint As Double = 0.6)
Call SetBGColor(rg, xlThemeColorAccent4, tint)
End Sub
' 设置水绿色背景（0.8 0.6 0.4 -0.25 -0.5）
Sub CyanBGColor(rg As Range, Optional tint As Double = 0.6)
Call SetBGColor(rg, xlThemeColorAccent5, tint)
End Sub
' 设置橙色背景（0.8 0.6 0.4 -0.25 -0.5）
Sub OrangeBGColor(rg As Range, Optional tint As Double = 0.6)
Call SetBGColor(rg, xlThemeColorAccent6, tint)
End Sub
' 设置单元格格式（日期）
Sub DateFormat(rg As Range)
rg.NumberFormatLocal = "m""月""d""日"";@"
End Sub
' 设置单元格格式（文本）
Sub TextFormat(rg As Range, center As Boolean)
rg.NumberFormatLocal = "@"
If center Then
rg.HorizontalAlignment = xlCenter ' 水平居左
Else
rg.HorizontalAlignment = xlLeft ' 水平居左
End If
End Sub
' 设置单元格格式（数值）
Sub NumFormat(rg As Range, center As Boolean)
rg.HorizontalAlignment = xlGeneral ' 水平居左
rg.NumberFormatLocal = "0.00_ ;[红色]-0.00 "
End Sub
' 设置单元格格式（带前导文本的数值）
Sub NamedNumFormat(rg As Range, prefix As String)
rg.NumberFormatLocal = """" + prefix + " ""#0.00;[红色]""" + prefix + " ""-#0.00"
End Sub
' 清除条件格式
Sub ClearFormatConditions(rg As Range)
rg.FormatConditions.Delete
End Sub
' 设置条件格式（零值与背景同色）
' redFG 单元格数值小于 0 时是否使用红色文本
' redBG 单元格数值小于 0 时是否使用红色背景
' noColor 单元格数值等于 0 时是否使文本与背景同色
Sub FormatCondition(rg As Range, redFG As Boolean, redBG As Boolean, noColor As Boolean)
' 清除条件格式
rg.FormatConditions.Delete
If redFG Then
' 设置条件格式（<0 红色字体）
rg.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="=0"
rg.FormatConditions(rg.FormatConditions.Count).SetFirstPriority
With rg.FormatConditions(1).Font
.color = 255
.TintAndShade = 0
End With
rg.FormatConditions(1).StopIfTrue = False
End If
If redBG Then
' 设置条件格式（<0 红色背景）
rg.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="=0"
rg.FormatConditions(rg.FormatConditions.Count).SetFirstPriority
With rg.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.color = 255
.TintAndShade = 0
End With
rg.FormatConditions(1).StopIfTrue = False
End If
If noColor Then
' 设置条件格式（=0 文本与背景同色）
rg.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0"
rg.FormatConditions(rg.FormatConditions.Count).SetFirstPriority
With rg.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
End With
rg.FormatConditions(1).StopIfTrue = False
End If
End Sub
' 冻结表格
Sub FreezeTable(rg As Range)
ActiveWindow.FreezePanes = False
rg.Select
ActiveWindow.FreezePanes = True
End Sub
' 锁定单元格
Sub LockTable(rg As Range)
rg.Locked = True
End Sub
' 解除单元格锁定
Sub UnLockCell(rg As Range)
rg.Locked = False
End Sub
' 保护工作表
Sub ProtectSheet(ws As Worksheet, passwd As String)
ws.Protect Password:=passwd, DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True, _
AllowFormattingColumns:=True, AllowFormattingRows:=True
End Sub
' 解除工作表保护
Sub UnProtectSheet(ws As Worksheet, passwd As String)
ws.Unprotect Password:=passwd
End Sub
' 选择含有公式的单元格
Function FormulasCells(ws As Worksheet) As Range
Set FormulasCells = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
End Function
扫一扫
7415
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
