EXCEL函数

weixin_44456861

已于 2022-08-04 13:20:50 修改

阅读量310

点赞数

文章标签：自动化

于 2022-08-04 10:52:23 首次发布

本文链接：https://blog.csdn.net/weixin_44456861/article/details/126153185

版权

1-1 使用Range属性引用单元格区域

Sub RngResize()
    Sheets("Sheet1").Range("A1").Resize(4, 4).Select
End Sub

1-2 使用Cell属性引用单元格区域

Sub MyCell()
    Dim i As Byte
    For i = 1 To 10
        Sheets("Sheet1").Cells(i, 2).Value = i
    Next
End Sub
'cells(i,2)从第二列开始写入1到10

1-3 使用快捷记号实现快速输入

Sub FastMark()
    [A1] = "Excel 2002"
End Sub

1-4 使用Offset属性返回单元格区域

OFFSET函数的功能为以指定的引用为参照系，通过给定偏移量得到新的引用。”

Sub RngOffset()
    Sheets("Sheet1").Range("A1:B2").Offset(2, 2).Select
'Range("范围")偏移量 Offset(2, 2)
End Sub

1-5 使用Resize属性返回调整后的单元格区域

A1开始选择4列4行

Sub RngResize()
    Sheets("Sheet1").Range("A1").Resize(4, 4).Select

2-1 使用Select方法选定单元格区域

Sub RngSelect()
    Sheets("Sheet2").Activate
    Sheets("Sheet2").Range("A1:B10").Select
End Sub

2-2 使用Activate方法选定单元格区域

Sub RngActivate()
    Sheets("Sheet2").Activate
    Sheets("Sheet2").Range("A1:B10").Activate
End Sub

2-3 使用Goto方法选定单元格区域

Sub RngGoto()
    Application.Goto Reference:=Sheets("Sheet2").Range("A1：B10"), Scroll:=True
End 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 = Nothing
End Sub

范例4 使用SpecialCells方法定位单元格

Sub SpecialAddress()
    Dim rng As Range
    Set rng = Sheet1.UsedRange.SpecialCells(xlCellTypeFormulas)
    rng.Select
    MsgBox "工作表中有公式的单元格为： " & rng.Address
    Set rng = Nothing
End Sub

5-1 使用Find方法查找特定信息

'自动定位到范围内匹配的单元格  WITH  为范围
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 = Nothing
End Sub
'匹配的单元格赋黄色   改变6 可改变颜色
Sub 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 = Nothing
End Sub

5-2 使用Like运算符进行模式匹配查找

Option Explicit
Sub RngLike()
    Dim rng As Range
    Dim r As Integer
    r = 1
    Sheet1.Range("A:A").ClearContents
    For Each rng In Sheet2.Range("A1:A42")
        If rng.Text Like "*z*" Then
            Cells(r, 1) = rng.Text
            r = r + 1
        End If
    Next
    Set rng = Nothing
End Sub
'sheet2范围内填写到sheet1  like指令和sql差不多

范例6 替换单元格内字符串

Sub Replacement()
    Range("A:A").Replace _
        What:="局", Replacement:="科", _
        LookAt:=xlPart, SearchOrder:=xlByRows, _
        MatchCase:=True
'A列 局替换为科

7-1 复制单元格区域

Option Explicit
Sub RangeCopy()
    Sheet1.Range("A1:B7").Copy Sheet2.Range("A1")
End Sub
'范围复制


Sub 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
    Next
End Sub

’全部复制

7-2 仅复制数值到另一区域

Option Explicit
Sub CopyValue()
    Sheet1.Range("A1:G7").Copy
    Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End Sub
'复制数值
Sub GetValueResize()
    With Sheet1.Range("A1").CurrentRegion
        Sheet3.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With
End Sub
'直接赋值

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

Option Explicit
Private Sub Worksheet_Deactivate()
    Application.CellDragAndDrop = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 1 Then
        Application.CellDragAndDrop = False
    Else
        Application.CellDragAndDrop = True
    End If
End Sub

范例9 设置单元格格式

Option Explicit
Sub CellFont()
    With Range("A1").Font
        .Name = "华文彩云"
        .FontStyle = "Bold"
        .Size = 22
        .ColorIndex = 3
        .Underline = 2
    End With
End Sub
'设置单元格字体格式
Option Explicit
Sub CellInternalFormat()
    With Range("A1").Interior
        .ColorIndex = 3
        .Pattern = xlPatternGrid
        .PatternColorIndex = 6
    End With
End Sub
'设置单元格内部格式

Option Explicit
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 = Nothing


End Sub
Sub QuickBorder()
    Range("B12:E18").Borders.LineStyle = xlContinuous
End Sub  '主要用这个

'单元格内加边框

10-1 添加数据有效性

Option Explicit
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 With
End Sub

10-2 判断是否存在数据有效性

Option Explicit
Sub ErrValidation()
    On Error GoTo Line
    If Range("A1").Validation.Type >= 0 Then
        MsgBox "有数据有效性!"
        Exit Sub
    End If
Line:
    MsgBox "没有数据有效性!"
End Sub

10-2 判断动态数据有效性

Option Explicit
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:="Z286,Z386,Z486,Z586"
                Case "显示器"
                    .Add Type:=xlValidateList, _
                        AlertStyle:=xlValidAlertStop, _
                        Operator:=xlBetween, _
                        Formula1:="15,17,21,25"
            End Select
        End With
    End If
End Sub

11-1 在单元格中写入公式

Option Explicit
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 Sub
Sub 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[-1]C)"
End Sub
Sub 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[-1]C[-2]*R[-" & r - 1 & "]C[-1]:R[-1]C[-1])"
    'Range("C" & r + 1).FormulaArray = "=SUM(A2:A" & r & "*B2:B" & r & ")"
End Sub

11-2 判断单元格是否包含公式

Option Explicit
Sub rngIsHasFormula()
    Select Case Selection.HasFormula
        Case True
            MsgBox "单元格包含公式!"
        Case False
            MsgBox "单元格没有公式!"
        Case Else
            MsgBox "公式区域：" & Selection.SpecialCells(-4123, 23).Address(0, 0)
    End Select
End Sub

范例12 为单元格添加批注 date加内容

Sub AddComment()
    With Range("A1")
        If Not .Comment Is Nothing Then .Comment.Delete
        .AddComment Text:=Date & vbCrLf & .Text
        .Comment.Visible = True
    End With
End Sub

13-1 判断单元格区域是否存在合并单元格

Option Explicit
Sub IsMergeCell()
    If Range("A1").MergeCells Then
        MsgBox "合并单元格", vbInformation
    Else
        MsgBox "非合并单元格", vbInformation
    End If
End Sub
Sub IsMergeCells()
    If IsNull(Range("A1:D10").MergeCells) Then
        MsgBox "包含合并单元格", vbInformation
    Else
        MsgBox "没有包含合并单元格", vbInformation
    End If
End Sub