VBA 技巧一

Public Sub 技巧()#判断单元格是否有公式
    Dim myRange As Range
    Set myRange = Range("A1")     '指定任意单元格
    If myRange.HasFormula = True Then
        MsgBox "单元格 " & myRange.Address & " 内有计算公式。"
    Else
        MsgBox "没有输入计算公式。"
    End If
    Set myRange = Nothing
End Sub

 

Public Sub 技巧()#复制单元格边框
    Dim myRange1 As Range
    Dim myRange2 As Range
    Dim cel As Range
    Set myRange1 = Range("A1:A7")     '指定要复制的单元格区域
    Set myRange2 = Range("D1")        '指定要复制的位置（左上角单元格）
    With myRange1
        Set myRange2 = myRange2.Resize(RowSize:=.Rows.Count, ColumnSize:=.Columns.Count)
        For Each cel In .Cells
            For i = xlDiagonalDown To xlEdgeRight
                Set myBrd = myRange2.Range(cel.Address).Borders(i)
                With cel.Borders(i)
                    myBrd.LineStyle = .LineStyle
                    myBrd.Weight = .Weight
                    myBrd.ColorIndex = .ColorIndex
                End With
            Next
        Next
    End With
    Set cel = Nothing
    Set myRange1 = Nothing
    Set myRange2 = Nothing
End Sub

Public Sub 技巧()#复制单元格批注
    Dim myRange1 As Range
    Dim myRange2 As Range
    Columns("D:D").Clear
    Set myRange1 = Range("A1:A7")     '指定要复制的单元格区域
    Set myRange2 = Range("D1")        '指定要复制的位置（左上角单元格）
    myRange1.Copy
    myRange2.PasteSpecial Paste:=xlPasteComments    '复制批注
    Set myRange1 = Nothing
    Set myRange2 = Nothing
End Sub

Public Sub 技巧()
    Dim myRange1 As Range
    Dim myRange2 As Range
    Columns("D:D").Clear
    Set myRange1 = Range("A1:A7")     '指定要复制的单元格区域
    Set myRange2 = Range("D1")        '指定要复制的位置（左上角单元格）
    myRange1.Copy
    myRange2.PasteSpecial Paste:=xlPasteValidation   '复制单元格的有效性
    Set myRange1 = Nothing
    Set myRange2 = Nothing
End Sub

Public Sub 技巧()#复制单元格字体
    Dim myRange As Range
    Dim myChr As Characters
    Set myRange = Range("A1")    '指定任意的单元格区域
    Cells.Clear    '清除工作表数据
    With myRange
        .Value = "ExcelVBA使用技巧手册"
        MsgBox "下面将“技巧”两字设置为加粗及斜体,15号字,华文新魏字体,红色。"
        Set myChr = .Characters(Start:=11, Length:=2)
        With myChr.Font
            .Name = "华文新魏"
            .Size = 15
            .Bold = True
            .Italic = True
            .ColorIndex = 3
        End With
    End With
    Set myChr = Nothing
    Set myRange = Nothing
End Sub

 

Public Sub 技巧()#区域右下角地址
    Dim myRange1 As Range, myRange2 As Range
    Set myRange1 = ActiveSheet.UsedRange    '指定任意的单元格区域
    With myRange1
        Set myRange2 = .Cells(.Cells.Count)
    End With
    MsgBox "该单元格区域右下角单元格的地址为： " & myRange2.Address
    Set myRange1 = Nothing
    Set myRange2 = Nothing
End Sub

 

Public Sub 技巧()#单元格边框格式
    Dim myRange As Range
    Set myRange = Range("A1")    '指定任意的单元格
    MsgBox "单元格" & myRange.Address & "的内部对象如下：" _
        & vbCrLf & "框线颜色：" & myRange.Borders.ColorIndex _
        & vbCrLf & "框线类型：" & myRange.Borders.LineStyle _
        & vbCrLf & "框线粗细：" & myRange.Borders.Weight
    Set myRange = Nothing
End Sub

Public Sub 技巧() '单元格的数字格式
    Dim myRange As Range
    Set myRange = Range("A1")    '指定任意的单元格
    MsgBox "单元格" & myRange.Address & "的格式为：" & myRange.NumberFormatLocal
    Set myRange = Nothing
End Sub

Public Sub 技巧() '单元格的数字格式
    Dim myRange As Range
    Set myRange = Range("A1")    '指定任意的单元格
    MsgBox "单元格" & myRange.Address & "的格式为：" & myRange.NumberFormatLocal
    Set myRange = Nothing
End Sub

Public Sub 技巧()'获取指定单元格区域的起始和终止行号
    Dim RowBegin As Integer, RowEnd As Integer
    Dim myRange As Range
    Set myRange = ActiveSheet.UsedRange   '指定任意的单元格区域
    RowBegin = myRange.Cells(1).Row       '获取该单元格区域的起始行号
    RowEnd = myRange.Cells(myRange.Count).Row       '获取该单元格区域的终止行号
    MsgBox "指定单元格区域的起始行号为 " & RowBegin _
        & vbCrLf & "指定单元格区域的终止行号为 " & RowEnd
    Set myRange = Nothing
End Sub

 

Public Sub 技巧()'获得单元格的填充图案
    Dim myRange As Range
    Set myRange = Range("A1")    '指定任意的单元格
    MsgBox "单元格" & myRange.Address & "的内部对象如下：" _
        & vbCrLf & "填充颜色：" & myRange.Interior.ColorIndex _
        & vbCrLf & "内部图案：" & myRange.Interior.Pattern _
        & vbCrLf & "内部图案颜色：" & myRange.Interior.PatternColorIndex
    Set myRange = Nothing
End Sub

Public Sub 技巧()‘获取指定单元格的字体格式
    Dim myRange As Range
    Set myRange = Range("A1")    '指定任意的单元格
    MsgBox "单元格" & myRange.Address & "的字体对象如下：" _
        & vbCrLf & "名称：" & myRange.Font.Name _
        & vbCrLf & "字形：" & myRange.Font.FontStyle _
        & vbCrLf & "字号：" & myRange.Font.Size _
        & vbCrLf & "颜色：" & myRange.Font.ColorIndex _
        & vbCrLf & "下划线：" & myRange.Font.Underline
    Set myRange = Nothing
End Sub

Public Sub 技巧()’获取指定字符串的单元格地址
    Dim myRange As Range, myCell As Range
    Dim myString As String, myText As String
    Set myRange = ActiveSheet.UsedRange    '指定任意的单元格区域
    myText = "电脑"     '指定要查找的字符串
    For Each myCell In myRange
        If InStr(LCase(myCell.Text), LCase(myText)) > 0 Then
            If Len(myString) = 0 Then
                myString = myCell.Address(False, False)
            Else
                myString = myString & "," & myCell.Address(False, False)
            End If
        End If
    Next
    If Len(myString) > 0 Then
        Range(myString).Select
        MsgBox "输入有字符串 " & myText & " 的单元格有：" & myString
    Else
        MsgBox "没有要查找的单元格。"
    End If
    Set myRange = Nothing
End Sub

Public Sub 技巧()‘快速输入指定日期
    Dim myRange As Range
    Cells.Clear     '删除工作表的数据
    Set myRange = Range("A1:A20")    '指定任意的单元格区域
    With myRange.Cells(1)
        .Value = #5/20/2006#    '设定初始日期
        .AutoFill Destination:=myRange, Type:=xlFillDays
    End With
    Set myRange = Nothing
End Sub

Public Sub 技巧()’批量设置单元格格式
    Dim myRange As Range
    Set myRange = Range("A1:F3")        '指定任意单元格区域
    MsgBox "下面将单元格区域 " & myRange.Address(False, False) _
        & " 的格式删除。"
    myRange.ClearFormats    '删除格式
    MsgBox "下面将单元格区域 " & myRange.Address(False, False) _
        & " 自动套用<会计1>的格式。"
    myRange.AutoFormat xlRangeAutoFormatAccounting1
    Set myRange = Nothing
End Sub

Public Sub 技巧()‘显示所选单元格的地址
    Dim myRange As Range
    Dim myString As String
    myString = "请用鼠标选取单元格，然后单击确定按钮。"
    On Error Resume Next
    Set myRange = Application.InputBox(myString, Type:=8)
    On Error GoTo 0
    If myRange Is Nothing Then
        MsgBox "已经取消操作。"
    Else
        MsgBox "选择的单元格（区域）地址为： " & myRange.Address
    End If
    Set myRange = Nothing
End Sub

Public Sub 技巧()’选择不连续的行
    Dim myRange As Range
    Set myRange = Range("1:1,3:3,5:5")
    myRange.Select
    Set myRange = Nothing
End Sub

Public Sub 技巧()‘指定单元格区域包含常量的单元格地址
    Dim myRange1 As Range, myRange2 As Range
    Set myRange1 = ActiveSheet.UsedRange    '指定任意的单元格区域
    Set myRange2 = myRange1.SpecialCells(xlCellTypeConstants)
    myRange2.Select
    MsgBox "指定单元格区域内输入有常量的单元格的地址为： " & myRange2.Address
    Set myRange1 = Nothing
    Set myRange2 = Nothing
End Sub

 

Sub aa() '复制sheet1中的A1:A5，转置粘贴到Sheet2的A1单元格
Worksheets("Sheet1").Range("A1:A5").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial Transpose:=True
End Sub