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在这段代码的基础上增加一个功能:若行中有单元格的填充颜色为黄色,则将该行的第一列零件编码中的值标红
最新发布