Excel VBA 共五章学习实例第12679章实用VBA源代码.docx

1、Excel VBA 共五章学习实例第12679章实用VBA源代码第1章 Range（单元格）对象（范例1范例17）第2章 Sheet（工作表）对象（范例18范例37）第6章 控件与用户窗体（范例67 范例112）第7章 使用对话框（范例113 范例118）第9章 文件操作（范例134 范例143）范例1 单元格的引用方法(返回)使用Range属性引用单元格区域Sub MyRng()Range(A1:B4, D5:E8).SelectRange(A1).Formula = =Rand()Range(A1:B4 B2:C6).Value = 10Range(A1, B4).Font.Italic

2、= TrueEnd Sub使用Cells属性引用单元格区域Sub MyCell()Dim i As ByteFor i = 1 To 10Sheets(Sheet1).Cells(i, 1).Value = iNextEnd Sub使用快捷记号实现快速输入Sub FastMark()A1 = Excel 2007End Sub使用Offset属性返回单元格区域Sub RngOffset()Sheets(Sheet1).Range(A1:B2).Offset(2, 2).SelectEnd Sub使用Resize属性返回调整后的单元格区域Sub RngResize()Sheets(Sheet1)

3、.Range(A1).Resize(4, 4).SelectEnd Sub范例2 选定单元格区域的方法使用Select方法Sub RngSelect()Sheets(Sheet2).ActivateSheets(Sheet2).Range(A1:B10).SelectEnd Sub使用Activate方法Sub RngActivate()Sheets(Sheet2).ActivateSheets(Sheet2).Range(A1:B10).ActivateEnd Sub使用Goto方法Sub RngGoto()Application.Goto Reference:=Sheets(Sheet2)

4、.Range(A1：B10), Scroll:=TrueEnd Sub范例3 获得指定行的最后一个非空单元格Sub LastCell()Dim rng As RangeSet rng = Cells(Rows.Count, 1).End(xlUp)MsgBox A列的最后一个非空单元格是 & rng.Address(0, 0) _& ,行号 & rng.Row & ,数值 & rng.ValueSet rng = NothingEnd Sub范例4 使用SpecialCells方法定位单元格Sub SpecialAddress()Dim rng As RangeSet rng = Sheet1

5、.UsedRange.SpecialCells(xlCellTypeFormulas)rng.SelectMsgBox 工作表中有公式的单元格为： & rng.AddressSet rng = NothingEnd Sub范例5 查找特定内容的单元格使用Find方法查找特定信息Sub FindCell()Dim StrFind As StringDim rng As RangeStrFind = InputBox(请输入要查找的值：)If Len(Trim(StrFind) 0 ThenWith Sheet1.Range(A:A)Set rng = .Find(What:=StrFind, _

6、After:=.Cells(.Cells.Count), _LookIn:=xlValues, _LookAt:=xlWhole, _SearchOrder:=xlByRows, _SearchDirection:=xlNext, _MatchCase:=False)If Not rng Is Nothing ThenApplication.Goto rng, TrueElseMsgBox 没有找到匹配单元格!End IfEnd WithEnd IfSet rng = NothingEnd SubSub FindNextCell()Dim StrFind As StringDim rng As

7、 RangeDim FindAddress As StringStrFind = InputBox(请输入要查找的值：)If Len(Trim(StrFind) 0 ThenWith Sheet1.Range(A:A).Interior.ColorIndex = 0Set rng = .Find(What:=StrFind, _After:=.Cells(.Cells.Count), _LookIn:=xlValues, _LookAt:=xlWhole, _SearchOrder:=xlByRows, _SearchDirection:=xlNext, _MatchCase:=False)I

8、f Not rng Is Nothing ThenFindAddress = rng.AddressDorng.Interior.ColorIndex = 6Set rng = .FindNext(rng)Loop While Not rng Is Nothing _And rng.Address FindAddressEnd IfEnd WithEnd IfSet rng = NothingEnd Sub使用Like运算符进行模式匹配查找Sub RngLike()Dim rng As RangeDim r As Integerr = 1Sheet1.Range(A:A).ClearConte

9、ntsFor Each rng In Sheet2.Range(A1:A40)If rng.Text Like *a* ThenCells(r, 1) = rng.Textr = r + 1End IfNextSet rng = NothingEnd Sub范例6 替换单元格内字符串Sub Replacement()Range(A:A).Replace _What:=市, Replacement:=区, _LookAt:=xlPart, SearchOrder:=xlByRows, _MatchCase:=TrueEnd Sub范例7 单元格的复制复制单元格区域Sub RangeCopy()S

10、heet1.Range(A1:G7).Copy Sheet2.Range(A1)End SubSub Copyalltheforms()Dim i As IntegerSheet1.Range(A1:G7).CopyWith Sheet3.Range(A1).PasteSpecial xlPasteAll.PasteSpecial xlPasteColumnWidthsEnd WithApplication.CutCopyMode = FalseFor i = 1 To 7Sheet3.Rows(i).RowHeight = Sheet1.Rows(i).RowHeightNextEnd Su

11、b仅复制数值到另一区域Sub CopyValue()Sheet1.Range(A1:G7).CopySheet2.Range(A1).PasteSpecial Paste:=xlPasteValuesApplication.CutCopyMode = FalseEnd SubSub GetValueResize()With Sheet1.Range(A1).CurrentRegionSheet3.Range(A1).Resize(.Rows.Count, .Columns.Count).Value = .ValueEnd WithEnd Sub范例8 禁用单元格拖放功能Private Sub

12、Worksheet_SelectionChange(ByVal Target As Range)If Target.Column = 1 ThenApplication.CellDragAndDrop = FalseElseApplication.CellDragAndDrop = TrueEnd IfEnd SubPrivate Sub Worksheet_Deactivate()Application.CellDragAndDrop = TrueEnd Sub范例9 设置单元格格式设置单元格字体格式Sub CellFont()With Range(A1).Font.Name = 华文彩云.

13、FontStyle = Bold.Size = 22.ColorIndex = 3.Underline = 2End WithEnd Sub设置单元格内部格式Sub CellInternalFormat()With Range(A1).Interior.ColorIndex = 3.Pattern = xlPatternGrid.PatternColorIndex = 6End WithEnd Sub单元格区域添加边框Sub CellBorder()Dim rng As RangeSet rng = Range(B2:E8)With rng.Borders(xlInsideHorizontal

14、).LineStyle = xlDot.Weight = xlThin.ColorIndex = xlColorIndexAutomaticEnd WithWith rng.Borders(xlInsideVertical).LineStyle = xlContinuous.Weight = xlThin.ColorIndex = xlColorIndexAutomaticEnd Withrng.BorderAround xlContinuous, xlMedium, xlColorIndexAutomaticSet rng = NothingEnd SubSub QuickBorder()R

15、ange(B12:E18).Borders.LineStyle = xlContinuousEnd Sub范例10 单元格的数据有效性添加数据有效性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 Sub判断是否存在数据有效性Sub Er

16、rValidation()On Error GoTo LineIf Range(A1).Validation.Type = 0 ThenMsgBox 有数据有效性!Exit SubEnd IfLine:MsgBox 没有数据有效性!End Sub动态的数据有效性Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Column = 1 And Target.Count = 1 And Target.Row 1 ThenWith Target.Validation.Delete.Add Type:=xlVali

17、dateList, _AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, _Formula1:=主机,显示器End WithEnd IfEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 1 And Target.Row 1 And Target.Count = 1 ThenWith Target.Offset(0, 1).Validation.DeleteSelect Case TargetCase 主机.Add Type:=xlValid

18、ateList, _AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, _Formula1:=Z286,Z386,Z486,Z586Case 显示器.Add Type:=xlValidateList, _AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, _Formula1:=15,17,21,25End SelectEnd WithEnd IfEnd Sub范例11 单元格中的公式在单元格中写入公式Sub rngFormula()Dim r As Integerr = Cells(Rows

19、.Count, 1).End(xlUp).RowRange(C2).Formula = =A2*B2Range(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 Integerr = Cells(Rows.Count, 1).End(xlUp).RowRange(C2:C & r).FormulaR1C1 = =RC-2*RC-1Range(A & r + 1) = 合计Range(C & r + 1

20、).FormulaR1C1 = =SUM(R- & r - 1 & C:R-1C)End SubSub RngFormulaArray()Dim r As Integerr = Cells(Rows.Count, 1).End(xlUp).RowRange(C2:C & r).FormulaR1C1 = =RC-2*RC-1Range(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 Sub判断单元格是否包含公式Sub rngIsHasF

21、ormula()Select Case Selection.HasFormulaCase TrueMsgBox 单元格包含公式!Case FalseMsgBox 单元格没有公式!Case ElseMsgBox 公式区域： & Selection.SpecialCells(-4123, 23).Address(0, 0)End SelectEnd Sub判断单元格公式是否存在错误Sub CellFormulaIsWrong()If IsError(Range(A1).Value) = True ThenMsgBox A1单元格错误类型为: & Range(A1).TextElseMsgBox A

22、1单元格公式结果为 & Range(A1).ValueEnd IfEnd Sub取得公式的引用单元格Sub RngPrecedent()Dim rng As RangeSet rng = Sheet1.Range(C10).PrecedentsMsgBox 公式所引用的单元格是： & rng.AddressSet rng = NothingEnd Sub将公式转换为数值Sub SpecialPaste()With Range(A1:A10).Copy.PasteSpecial Paste:=xlPasteValuesEnd WithApplication.CutCopyMode = False

23、End Sub范例12 单元格添加批注Sub AddComment()With Range(A1)If Not .Comment Is Nothing Then .Comment.Delete.AddComment Text:=Date & vbCrLf & .Text.Comment.Visible = TrueEnd WithEnd Sub范例13 合并单元格操作判断单元格区域是否存在合并单元格Sub IsMergeCell()If Range(A1).MergeCells ThenMsgBox 合并单元格, vbInformationElseMsgBox 非合并单元格, vbInform

24、ationEnd IfEnd SubSub IsMergeCells()If IsNull(Range(A1:D10).MergeCells) ThenMsgBox 包含合并单元格, vbInformationElseMsgBox 没有包含合并单元格, vbInformationEnd IfEnd Sub合并单元格时连接每个单元格的文本Sub MergeCells()Dim MergeStr As StringDim MergeRng As RangeDim rng As RangeSet MergeRng = Range(A1:B2)For Each rng In MergeRngMerge

25、Str = MergeStr & rng & NextApplication.DisplayAlerts = FalseMergeRng.MergeMergeRng.Value = MergeStrApplication.DisplayAlerts = TrueSet MergeRng = NothingSet rng = NothingEnd Sub合并内容相同的连续单元格Sub MergeLinkedCell()Dim r As IntegerDim i As IntegerApplication.DisplayAlerts = FalseWith Sheet1r = .Cells(Row

26、s.Count, 1).End(xlUp).RowFor i = r To 2 Step -1If .Cells(i, 2).Value = .Cells(i - 1, 2).Value Then.Range(.Cells(i - 1, 2), .Cells(i, 2).MergeEnd IfNextEnd WithApplication.DisplayAlerts = TrueEnd Sub取消合并单元格时在每个单元格中保留内容Sub CancelMergeCells()Dim r As IntegerDim MergeStr As StringDim MergeCot As Integer

27、Dim i As IntegerWith Sheet1r = .Cells(.Rows.Count, 1).End(xlUp).RowFor i = 2 To rMergeStr = .Cells(i, 2).ValueMergeCot = .Cells(i, 2).MergeArea.Count.Cells(i, 2).UnMerge.Range(.Cells(i, 2), .Cells(i + MergeCot - 1, 2).Value = MergeStri = i + MergeCot - 1Next.Range(B1:B & r).Borders.LineStyle = xlCon

28、tinuousEnd WithEnd Sub范例14 高亮显示选定单元格区域Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlColorIndexNoneTarget.Interior.ColorIndex = Int(56 * Rnd() + 1)End SubPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)Dim rng As RangeCells.Interior.ColorIndex =

29、 xlColorIndexNoneSet 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 ThenMsgBox 此单元格已保护，不能编辑!Cancel = TrueEnd IfEnd Sub范例16 单元格录入数据后自动保护Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim msg As ByteWith TargetIf Not Application.Intersect(Target, Range(A2:F6) Is