第1章 Range(单元格)对象【超实用VBA】.doc

第1章 Range（单元格）对象范例1 单元格的引用方法1-1 使用Range属性引用单元格区域Sub MyRng() Range(A1:B4, D5:E8).Select Range(A1).Formula = =Rand() Range(A1:B4 B2:C6).Value = 10 Range(A1, B4).Font.Italic = TrueEnd Sub1-2 使用Cells属性引用单元格区域Sub MyCell() Dim i As Byte For i = 1 To 10 Sheets(Sheet1).Cells(i, 1).Value = i NextEnd Sub1-3 使用快捷记号实现快速输入Sub FastMark() A1 = Excel 2007End Sub1-4 使用Offset属性返回单元格区域Sub RngOffset() Sheets(Sheet1).Range(A1:B2).Offset(2, 2).SelectEnd Sub1-5 使用Resize属性返回调整后的单元格区域Sub RngResize() Sheets(Sheet1).Range(A1).Resize(4, 4).SelectEnd Sub范例2 选定单元格区域的方法2-1 使用Select方法Sub RngSelect() Sheets(Sheet2).Activate Sheets(Sheet2).Range(A1:B10).SelectEnd Sub2-2 使用Activate方法Sub RngActivate() Sheets(Sheet2).Activate Sheets(Sheet2).Range(A1:B10).ActivateEnd Sub2-3 使用Goto方法Sub RngGoto() Application.Goto Reference:=Sheets(Sheet2).Range(A1：B10), Scroll:=TrueEnd Sub范例3 获得指定行的最后一个非空单元格Sub LastCell() Dim rng As Range Set rng = Cells(Rows.Count, 1).End(xlUp) MsgBox A列的最后一个非空单元格是 & rng.Address(0, 0) _ & ,行号 & rng.Row & ,数值 & rng.Value Set rng = NothingEnd Sub范例4 使用SpecialCells方法定位单元格Sub SpecialAddress() Dim rng As Range Set rng = Sheet1.UsedRange.SpecialCells(xlCellTypeFormulas) rng.Select MsgBox 工作表中有公式的单元格为： & rng.Address Set rng = NothingEnd Sub范例5 查找特定内容的单元格5-1 使用Find方法查找特定信息Sub FindCell() Dim StrFind As String Dim rng As Range StrFind = InputBox(请输入要查找的值：) If Len(Trim(StrFind) 0 Then With Sheet1.Range(A:A) Set rng = .Find(What:=StrFind, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not rng Is Nothing Then Application.Goto rng, True Else MsgBox 没有找到匹配单元格! End If End With End If Set rng = NothingEnd SubSub FindNextCell() Dim StrFind As String Dim rng As Range Dim FindAddress As String StrFind = InputBox(请输入要查找的值：) If Len(Trim(StrFind) 0 Then With Sheet1.Range(A:A) .Interior.ColorIndex = 0 Set rng = .Find(What:=StrFind, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not rng Is Nothing Then FindAddress = rng.Address Do rng.Interior.ColorIndex = 6 Set rng = .FindNext(rng) Loop While Not rng Is Nothing _ And rng.Address FindAddress End If End With End If Set rng = NothingEnd Sub5-2 使用Like运算符进行模式匹配查找Sub RngLike() Dim rng As Range Dim r As Integer r = 1 Sheet1.Range(A:A).ClearContents For Each rng In Sheet2.Range(A1:A40) If rng.Text Like *a* Then Cells(r, 1) = rng.Text r = r + 1 End If Next Set rng = NothingEnd Sub范例6 替换单元格内字符串Sub Replacement() Range(A:A).Replace _ What:=市, Replacement:=区, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=TrueEnd Sub范例7 单元格的复制7-1 复制单元格区域Sub RangeCopy() Sheet1.Range(A1:G7).Copy Sheet2.Range(A1)End SubSub Copyalltheforms() Dim i As Integer Sheet1.Range(A1:G7).Copy With Sheet3.Range(A1) .PasteSpecial xlPasteAll .PasteSpecial xlPasteColumnWidths End With Application.CutCopyMode = False For i = 1 To 7 Sheet3.Rows(i).RowHeight = Sheet1.Rows(i).RowHeight NextEnd Sub7-2 仅复制数值到另一区域Sub CopyValue() Sheet1.Range(A1:G7).Copy Sheet2.Range(A1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = FalseEnd SubSub GetValueResize() With Sheet1.Range(A1).CurrentRegion Sheet3.Range(A1).Resize(.Rows.Count, .Columns.Count).Value = .Value End WithEnd Sub范例8 禁用单元格拖放功能Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 Then Application.CellDragAndDrop = False Else Application.CellDragAndDrop = True End IfEnd SubPrivate Sub Worksheet_Deactivate() Application.CellDragAndDrop = TrueEnd Sub范例9 设置单元格格式9-1 设置单元格字体格式Sub CellFont() With Range(A1).Font .Name = 华文彩云 .FontStyle = Bold .Size = 22 .ColorIndex = 3 .Underline = 2 End WithEnd Sub9-2 设置单元格内部格式Sub CellInternalFormat() With Range(A1).Interior .ColorIndex = 3 .Pattern = xlPatternGrid .PatternColorIndex = 6 End WithEnd Sub9-3 单元格区域添加边框Sub CellBorder() Dim rng As Range Set rng = Range(B2:E8) 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 = NothingEnd SubSub QuickBorder() Range(B12:E18).Borders.LineStyle = xlContinuousEnd Sub范例10 单元格的数据有效性10-1 添加数据有效性Sub AddValidation() With Range(A1:A10).Validation .Delete .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:=1,2,3,4,5,6,7,8 .ErrorMessage = 只能输入1-8的数值,请重新输入! End WithEnd Sub10-2 判断是否存在数据有效性Sub ErrValidation() On Error GoTo Line If Range(A1).Validation.Type = 0 Then MsgBox 有数据有效性! Exit Sub End IfLine: MsgBox 没有数据有效性!End Sub10-3 动态的数据有效性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 IfEnd SubPrivate 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:=Z286,Z386,Z486,Z586 Case 显示器 .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:=15,17,21,25 End Select End With End IfEnd Sub范例11 单元格中的公式11-1 在单元格中写入公式Sub rngFormula() Dim r As Integer r = Cells(Rows.Count, 1).End(xlUp).Row Range(C2).Formula = =A2*B2 Range(C2).Copy Range(C3:C & r) Range(A & r + 1) = 合计 Range(C & r + 1).Formula = =SUM(C2:C & r & )End SubSub rngFormulaRC() Dim r As Integer r = Cells(Rows.Count, 1).End(xlUp).Row Range(C2:C & r).FormulaR1C1 = =RC-2*RC-1 Range(A & r + 1) = 合计 Range(C & r + 1).FormulaR1C1 = =SUM(R- & r - 1 & C:R-1C)End SubSub RngFormulaArray() Dim r As Integer r = Cells(Rows.Count, 1).End(xlUp).Row Range(C2:C & r).FormulaR1C1 = =RC-2*RC-1 Range(A & r + 1) = 合计 Range(C & r + 1).FormulaArray = =SUM(R- & r - 1 & C-2:R-1C-2*R- & r - 1 & C-1:R-1C-1)End Sub11-2 判断单元格是否包含公式Sub rngIsHasFormula() Select Case Selection.HasFormula Case True MsgBox 单元格包含公式! Case False MsgBox 单元格没有公式! Case Else MsgBox 公式区域： & Selection.SpecialCells(-4123, 23).Address(0, 0) End SelectEnd Sub11-3 判断单元格公式是否存在错误Sub CellFormulaIsWrong() If IsError(Range(A1).Value) = True Then MsgBox A1单元格错误类型为: & Range(A1).Text Else MsgBox A1单元格公式结果为 & Range(A1).Value End IfEnd Sub11-4 取得公式的引用单元格Sub RngPrecedent() Dim rng As Range Set rng = Sheet1.Range(C10).Precedents MsgBox 公式所引用的单元格是： & rng.Address Set rng = NothingEnd Sub11-5 将公式转换为数值Sub SpecialPaste() With Range(A1:A10) .Copy .PasteSpecial Paste:=xlPasteValues End With Application.CutCopyMode = FalseEnd Sub范例12 单元格添加批注Sub AddComment() With Range(A1) If Not .Comment Is Nothing Then .Comment.Delete .AddComment Text:=Date & vbCrLf & .Text .Comment.Visible = True End WithEnd Sub范例13 合并单元格操作13-1 判断单元格区域是否存在合并单元格Sub IsMergeCell() If Range(A1).MergeCells Then MsgBox 合并单元格, vbInformation Else MsgBox 非合并单元格, vbInformation End IfEnd SubSub IsMergeCells() If IsNull(Range(A1:D10).MergeCells) Then MsgBox 包含合并单元格, vbInformation Else MsgBox 没有包含合并单元格, vbInformation End IfEnd Sub13-2 合并单元格时连接每个单元格的文本Sub MergeCells() Dim MergeStr As String Dim MergeRng As Range Dim rng As Range Set MergeRng = Range(A1:B2) 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 = NothingEnd Sub13-3 合并内容相同的连续单元格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 = TrueEnd Sub13-4 取消合并单元格时在每个单元格中保留内容Sub CancelMergeCells() Dim r As Integer Dim MergeStr As String Dim MergeCot As Integer Dim i As Integer With Sheet1 r = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 2 To r MergeStr = .Cells(i, 2).Value MergeCot = .Cells(i, 2).MergeArea.Count .Cells(i, 2).UnMerge .Range(.Cells(i, 2), .Cells(i + MergeCot - 1, 2).Value = MergeStr i = i + MergeCot - 1 Next .Range(B1:B & r).Borders.LineStyle = xlContinuous End WithEnd Sub范例14 高亮显示选定单元格区域Private Sub Worksheet_SelectionChange(ByVal Target As Range) Cells.Interior.ColorIndex = xlColorIndexNone Target.Interior.ColorIndex = Int(56 * Rnd() + 1)End SubPrivate Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Cells.Interior.ColorIndex = xlColorIndexNone Set rng = Application.Union(Target.EntireColumn, Target.EntireRow) rng.Interior.ColorIndex = Int(56 * Rnd() + 1) Set rng = NothingEnd Sub范例15 双击被保护单元格时不显示提示消息框Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Locked = True Then MsgBox 此单元格已保护，不能编辑! Cancel = True End IfEnd Sub范例16 单元格录入数据后自动保护Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim msg As Byte With Target If Not Application.Intersect(Target, Range(A2:F6) Is Nothing Then If .Count 1 Then Range(A1).Select Exit Sub End If ActiveSheet.Unprotect If Len(Trim(.Value) 0 Then msg = MsgBox(当前单元格已录入数据,是否修改?, 32 + 4) .Lo