vba:格式字体font,颜色,ClearFormats 方法,Interior 对象

本文介绍了VBA中如何使用Font对象进行字体、字号、颜色等格式设置,以及通过ClearFormats方法清除格式。同时,文章还展示了如何利用Interior对象改变单元格的背景颜色,包括索引颜色值、早期颜色值、三原色颜色值和直接颜色值的设置方法。通过实例代码,读者可以学习到如何在Excel中实现动态颜色应用。

 

'Font 对象
'包含对象的字体属性(字体名称、字号、颜色等等)。

'Range.ClearFormats 方法
'清除对象的格式设置

'常见font对象的属性
Sub font对象属性()
With [a2:a6].Font
    .Name = "微软雅黑" '字体
    .Size = 8 '字号
    .Bold = True '加粗
    .Color = RGB(255, 0, 255) '颜色
End With
End Sub

Sub 大于90分的颜色设置为红色()
Set i = Cells(Rows.Count, 3).End(xlUp)
Range([b2], i).ClearFormats
For Each Rng In Range([b2], i)
    If Rng.Value >= [f1] Then
    With Rng.Font
        .Name = "华文琥珀"
        .Size = 20
        .Bold = True
        .Color = RGB(255, 0, 0)
    End With
    End If
Next Rng
End Sub

案例

 给你点颜色看看

1
2
3
4
5
6
Sub Beauty() ' 禁用非必要功能提升性能 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False On Error GoTo ErrorHandler ' 定义工作表 Dim wb As Workbook Set wb = ThisWorkbook Dim wsTrend As Worksheet Dim wsResult As Worksheet Set wsTrend = wb.Sheets("推移表") Set wsResult = wb.Sheets("结果") ' 检查工作表是否存在 If wsTrend Is Nothing Then MsgBox "错误:找不到 '推移表' 工作表!", vbCritical Exit Sub End If If wsResult Is Nothing Then MsgBox "错误:找不到 '结果' 工作表!", vbCritical Exit Sub End If ' 步骤1:清除结果工作表B1-P1区域 wsResult.Range("B1:P1").ClearContents wsResult.Range("B1:P1").ClearFormats Call Copy ' 步骤3:设置所有框线 Dim lastRow As Long Dim lastResultCol As Long ' 确定数据区域 lastRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row lastResultCol = wsResult.Cells(1, wsResult.Columns.Count).End(xlToLeft).Column ' 确保有足够的数据 If lastRow < 1 Or lastResultCol < 2 Then MsgBox "警告:'结果' 工作表没有足够的数据!", vbExclamation Else ' 设置所有框线 With wsResult.Range(wsResult.Cells(1, 1), wsResult.Cells(lastRow, lastResultCol)).Borders .LineStyle = xlContinuous .Weight = xlThin .Color = RGB(100, 100, 100) ' 深灰色边框 End With End If ' 步骤4:设置单元格背景色 If lastRow >= 2 And lastResultCol >= 10 Then Dim dataRange As Range Dim cell As Range ' 设置第三列到第十列的数据区域(从第二行开始) Set dataRange = wsResult.Range(wsResult.Cells(2, 3), wsResult.Cells(lastRow, 9)) ' 先全部填充绿色 dataRange.Interior.Color = RGB(198, 239, 206) ' 浅绿色 ' 然后检查标红的数据值并填充黄色 For Each cell In dataRange If cell.Font.Color = RGB(255, 0, 0) Then ' 检查是否标红 cell.Interior.Color = RGB(255, 255, 204) ' 浅黄色 End If Next cell End If ' 步骤5:美化标题行(第一行) With wsResult.Rows(1) .Font.Bold = True .Font.Size = 11 .Interior.Color = RGB(217, 217, 217) ' 浅灰色 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ' 步骤6:自动调整列宽 wsResult.Columns("A:Z").AutoFit GoTo Cleanup ErrorHandler: MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical, "运行时错误" Cleanup: ' 恢复Excel设置 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ' 释放对象 Set wsTrend = Nothing Set wsResult = Nothing Set wb = Nothing Set sourceRange = Nothing Set destRange = Nothing End SubSub Beauty() ' 禁用非必要功能提升性能 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False On Error GoTo ErrorHandler ' 定义工作表 Dim wb As Workbook Set wb = ThisWorkbook Dim wsTrend As Worksheet Dim wsResult As Worksheet Set wsTrend = wb.Sheets("推移表") Set wsResult = wb.Sheets("结果") ' 检查工作表是否存在 If wsTrend Is Nothing Then MsgBox "错误:找不到 '推移表' 工作表!", vbCritical Exit Sub End If If wsResult Is Nothing Then MsgBox "错误:找不到 '结果' 工作表!", vbCritical Exit Sub End If ' 步骤1:清除结果工作表B1-P1区域 wsResult.Range("B1:P1").ClearContents wsResult.Range("B1:P1").ClearFormats Call Copy ' 步骤3:设置所有框线 Dim lastRow As Long Dim lastResultCol As Long ' 确定数据区域 lastRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row lastResultCol = wsResult.Cells(1, wsResult.Columns.Count).End(xlToLeft).Column ' 确保有足够的数据 If lastRow < 1 Or lastResultCol < 2 Then MsgBox "警告:'结果' 工作表没有足够的数据!", vbExclamation Else ' 设置所有框线 With wsResult.Range(wsResult.Cells(1, 1), wsResult.Cells(lastRow, lastResultCol)).Borders .LineStyle = xlContinuous .Weight = xlThin .Color = RGB(100, 100, 100) ' 深灰色边框 End With End If ' 步骤4:设置单元格背景色 If lastRow >= 2 And lastResultCol >= 10 Then Dim dataRange As Range Dim cell As Range ' 设置第三列到第十列的数据区域(从第二行开始) Set dataRange = wsResult.Range(wsResult.Cells(2, 3), wsResult.Cells(lastRow, 9)) ' 先全部填充绿色 dataRange.Interior.Color = RGB(198, 239, 206) ' 浅绿色 ' 然后检查标红的数据值并填充黄色 For Each cell In dataRange If cell.Font.Color = RGB(255, 0, 0) Then ' 检查是否标红 cell.Interior.Color = RGB(255, 255, 204) ' 浅黄色 End If Next cell End If ' 步骤5:美化标题行(第一行) With wsResult.Rows(1) .Font.Bold = True .Font.Size = 11 .Interior.Color = RGB(217, 217, 217) ' 浅灰色 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ' 步骤6:自动调整列宽 wsResult.Columns("A:Z").AutoFit GoTo Cleanup ErrorHandler: MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical, "运行时错误" Cleanup: ' 恢复Excel设置 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ' 释放对象 Set wsTrend = Nothing Set wsResult = Nothing Set wb = Nothing Set sourceRange = Nothing Set destRange = Nothing End SubSub Beauty() ' 禁用非必要功能提升性能 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False On Error GoTo ErrorHandler ' 定义工作表 Dim wb As Workbook Set wb = ThisWorkbook Dim wsTrend As Worksheet Dim wsResult As Worksheet Set wsTrend = wb.Sheets("推移表") Set wsResult = wb.Sheets("结果") ' 检查工作表是否存在 If wsTrend Is Nothing Then MsgBox "错误:找不到 '推移表' 工作表!", vbCritical Exit Sub End If If wsResult Is Nothing Then MsgBox "错误:找不到 '结果' 工作表!", vbCritical Exit Sub End If ' 步骤1:清除结果工作表B1-P1区域 wsResult.Range("B1:P1").ClearContents wsResult.Range("B1:P1").ClearFormats Call Copy ' 步骤3:设置所有框线 Dim lastRow As Long Dim lastResultCol As Long ' 确定数据区域 lastRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row lastResultCol = wsResult.Cells(1, wsResult.Columns.Count).End(xlToLeft).Column ' 确保有足够的数据 If lastRow < 1 Or lastResultCol < 2 Then MsgBox "警告:'结果' 工作表没有足够的数据!", vbExclamation Else ' 设置所有框线 With wsResult.Range(wsResult.Cells(1, 1), wsResult.Cells(lastRow, lastResultCol)).Borders .LineStyle = xlContinuous .Weight = xlThin .Color = RGB(100, 100, 100) ' 深灰色边框 End With End If ' 步骤4:设置单元格背景色 If lastRow >= 2 And lastResultCol >= 10 Then Dim dataRange As Range Dim cell As Range ' 设置第三列到第十列的数据区域(从第二行开始) Set dataRange = wsResult.Range(wsResult.Cells(2, 3), wsResult.Cells(lastRow, 9)) ' 先全部填充绿色 dataRange.Interior.Color = RGB(198, 239, 206) ' 浅绿色 ' 然后检查标红的数据值并填充黄色 For Each cell In dataRange If cell.Font.Color = RGB(255, 0, 0) Then ' 检查是否标红 cell.Interior.Color = RGB(255, 255, 204) ' 浅黄色 End If Next cell End If ' 步骤5:美化标题行(第一行) With wsResult.Rows(1) .Font.Bold = True .Font.Size = 11 .Interior.Color = RGB(217, 217, 217) ' 浅灰色 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ' 步骤6:自动调整列宽 wsResult.Columns("A:Z").AutoFit GoTo Cleanup ErrorHandler: MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical, "运行时错误" Cleanup: ' 恢复Excel设置 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ' 释放对象 Set wsTrend = Nothing Set wsResult = Nothing Set wb = Nothing Set sourceRange = Nothing Set destRange = Nothing End Sub在这段代码的基础上增加一个功能:若行中有单元格的填充颜色为黄色,则将该行的第一列零件编码中的值标红
最新发布
07-17
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值