.Size = 22
.ColorIndex = 3 .Underline = 2 End With End Sub
设置单元格内部格式
Sub CellInternalFormat()
With Range(\
.ColorIndex = 3
.Pattern = xlPatternGrid .PatternColorIndex = 6 End With End Sub
单元格区域添加边框
Sub CellBorder()
Dim rng As Range
Set rng = Range(\
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlDot .Weight = xlThin
.ColorIndex = xlColorIndexAutomatic End With
With rng.Borders(xlInsideVertical)
.LineStyle = xlContinuous .Weight = xlThin
.ColorIndex = xlColorIndexAutomatic End With
rng.BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic Set rng = Nothing End Sub
Sub QuickBorder()
Range(\End Sub
范例10 单元格的数据有效性
添加数据有效性
Sub AddValidation()
With Range(\
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _ 6
Operator:=xlBetween, _
Formula1:=\
.ErrorMessage = \只能输入1-8的数值,请重新输入!\End With End Sub
判断是否存在数据有效性
Sub ErrValidation()
On Error GoTo Line
If Range(\
MsgBox \有数据有效性!\Exit Sub End If Line:
MsgBox \没有数据有效性!\End Sub
动态的数据有效性
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 And Target.Row > 1 Then
With Target.Validation
.Delete
.Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:=\主机,显示器\End With End If End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then
With Target.Offset(0, 1).Validation
.Delete
Select Case Target Case \主机\
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _
Formula1:=\
Case \显示器\
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:=\
End Select End With End If
7
End Sub
范例11 单元格中的公式
在单元格中写入公式
Sub rngFormula()
Dim r As Integer
r = Cells(Rows.Count, 1).End(xlUp).Row Range(\
Range(\Range(\合计\
Range(\End Sub
Sub rngFormulaRC()
Dim r As Integer
r = Cells(Rows.Count, 1).End(xlUp).Row
Range(\Range(\合计\
Range(\End Sub
Sub RngFormulaArray()
Dim r As Integer
r = Cells(Rows.Count, 1).End(xlUp).Row
Range(\Range(\合计\
Range(\& \End Sub
判断单元格是否包含公式
Sub rngIsHasFormula()
Select Case Selection.HasFormula
Case True
MsgBox \单元格包含公式!\Case False
MsgBox \单元格没有公式!\Case Else
MsgBox \公式区域：\
End Select End Sub
判断单元格公式是否存在错误
Sub CellFormulaIsWrong() 8
If IsError(Range(\
MsgBox \单元格错误类型为:\Else
MsgBox \单元格公式结果为\End If End Sub
取得公式的引用单元格
Sub RngPrecedent()
Dim rng As Range
Set rng = Sheet1.Range(\MsgBox \公式所引用的单元格是：\Set rng = Nothing End Sub
将公式转换为数值
Sub SpecialPaste()
With Range(\
.Copy
.PasteSpecial Paste:=xlPasteValues End With
Application.CutCopyMode = False End Sub
范例12 单元格添加批注
Sub AddComment()
With Range(\
If Not .Comment Is Nothing Then .Comment.Delete .AddComment Text:=Date & vbCrLf & .Text .Comment.Visible = True End With End Sub
范例13 合并单元格操作
判断单元格区域是否存在合并单元格
Sub IsMergeCell()
If Range(\
MsgBox \合并单元格\Else
MsgBox \非合并单元格\End If
9
End Sub
Sub IsMergeCells()
If IsNull(Range(\
MsgBox \包含合并单元格\Else
MsgBox \没有包含合并单元格\End If End Sub
合并单元格时连接每个单元格的文本
Sub MergeCells()
Dim MergeStr As String Dim MergeRng As Range Dim rng As Range
Set MergeRng = Range(\For Each rng In MergeRng
MergeStr = MergeStr & rng & \Next
Application.DisplayAlerts = False MergeRng.Merge
MergeRng.Value = MergeStr
Application.DisplayAlerts = True Set MergeRng = Nothing Set rng = Nothing End Sub
合并内容相同的连续单元格
Sub MergeLinkedCell()
Dim r As Integer Dim i As Integer
Application.DisplayAlerts = False With Sheet1
r = .Cells(Rows.Count, 1).End(xlUp).Row For i = r To 2 Step -1
If .Cells(i, 2).Value = .Cells(i - 1, 2).Value Then .Range(.Cells(i - 1, 2), .Cells(i, 2)).Merge End If Next End With
Application.DisplayAlerts = True End Sub
取消合并单元格时在每个单元格中保留内容
Sub CancelMergeCells()
Dim r As Integer
Dim MergeStr As String
10