Excel VBA 共五章学习实例（第1、2、6、7、9章）实用VBA源代码

With Sheet3.Range(\

.PasteSpecial xlPasteAll

.PasteSpecial xlPasteColumnWidths End With

Application.CutCopyMode = False For i = 1 To 7

Sheet3.Rows(i).RowHeight = Sheet1.Rows(i).RowHeight Next End Sub

仅复制数值到另一区域

Sub CopyValue()

Sheet1.Range(\

Sheet2.Range(\Application.CutCopyMode = False End Sub

Sub GetValueResize()

With Sheet1.Range(\

Sheet3.Range(\End With End Sub

范例8 禁用单元格拖放功能

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Column = 1 Then

Application.CellDragAndDrop = False Else

Application.CellDragAndDrop = True End If End Sub

Private Sub Worksheet_Deactivate()

Application.CellDragAndDrop = True End Sub

范例9 设置单元格格式

设置单元格字体格式

Sub CellFont()

With Range(\

.Name = \华文彩云\.FontStyle = \

5

.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