VBA代码优化及其他设置操作

一、代码优化的一些方法

• 尽量减少在循环中遍历调用对象，公式计算
• （操作VBA代码若出现屏幕闪屏，会拖慢运行速度），可以禁止屏幕闪屏。多用在操作工作表/薄，单元格的时候。

　　　　Application.ScreenUpdating = False

• 需声明变量类型，减少工作表函数的使用。（多写循环代替工作表函数）
• 减少VBA函数的使用，如int(10000/3) 可以用10000 3 替代
• 单元格填充数据前先清空单元格数据
• 批量操作及减少循环次数
• 巧妙填充公式，如单元格的filldown方法向下复制，避开循环

　　　　cell(2,a) =  " = b2*c2"

　　　　[a2:a100].FillDown

二、关于其他操作

1、字体及边框设置

Public Sub RngFont()
    With Range("d3").Font
    
        .Name = "华文彩云"
        .FontStyle = "Bold"
        .Size = 28
        .ColorIndex = 3
        .Underline = 5
    
    End With
    With Range("d3").Interior
        .Pattern = xlPatternCrissCross   '设置内部图案为十字图案
        .PatternColorIndex = 6
    End With

End Sub

2、单元格区域设置样式，borders方法，BorderAround 用于区域最外边框设置

Sub AddVBorders()
    Dim rng As Range
    Set rng = Range("a5:c9")
    With rng.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 5
    End With
    rng.BorderAround xlContinuous, xlMedium, 5
    Set rng = Nothing
    
End Sub

　BorderAround 后参数：

　

区域中多格式：

Sub bordersDemo()

    Dim rng As Range
    Set rng = Range("e5:g9")
    With rng.Borders(xlInsideHorizontal)
        .LineStyle = xlDot
        .Weight = xlThin
        .ColorIndex = 5
        
    End With
    With rng.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 5
        
    End With
    rng.BorderAround xlContinuous, xlMedium, 5
    
    Set rng = Nothing

End Sub

3、行高、列宽设置 （磅或厘米）

Sub RngToPoints()
    With Range("i14")
        .RowHeight = Application.CentimetersToPoints(1.2)
        .ColumnWidth = Application.CentimetersToPoints(0.8)
                 
    End With
    With Range("j15")
        .RowHeight = Application.InchesToPoints(0.5)
        .ColumnWidth = Application.InchesToPoints(0.2)
                 
    End With

End Sub

　样式如下：

 4、单元格数据有效性设置 Validation对象add方法

Sub Validation()
    
    '建立数据有效性
    With Range("a1:a3").Validation
        .Delete
        .Add Type:=xlValidateList, _
        Operator:=xlBetween, _
        Formula1:="1,2,3,4,5,6,7"  'formula1,formula2可设置有效性公式
                        
    End With
    
    '判断数据有效性
    On Error GoTo Line
    If Range("a1").Validation.Type >= 0 Then
        MsgBox "have validation"
        Exit Sub
    End If
Line:
    MsgBox "none"
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, _
            Operator:=xlBetween, _
            Formula1:="主机,显示器"
            
        End With
    End If
    If target.Column = 2 Then
        Application.SendKeys "%{down}"    ' 点击单元格自动下拉展示所有选项
    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:="三星1,飞利浦1,三星2,飞利浦2"
            End Select
        End With
    End If
End Sub

　

效果：

 5、检测选择区域是否含有公式（Hasformula函数），并输出公式位置

Private Sub CommandButton1_Click()
    Select Case Selection.HasFormula
        Case True
            MsgBox "公式单元格"
        Case False
            MsgBox "非公式单元格"
        Case Else
            MsgBox "公式位置" & Selection.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
    End Select
End Sub

若需要返回公式引用的单元格区域则使用公式单元格Precedents属性，exp:　　range("c1").Precedents.address(0,0)

6、判断是否为空

1）逻辑值判断 - 空时返回True

• range("a1")="" 
• len(range("a1")) = 0 
• VBA.IsEmpty(range("a1"))

2）值判断

• VBA.TypeName(range("a1").Value)  值返回为Empty时为空

7、判断是否为数字、文本、错误值、数组、日期

1）逻辑值判断

• VBA.IsNumeric(range("c1"))
• Application.WorkSheetFunction.IsNumber(range("c1"))

2) 值判断，不是返回Error--均用于判断数字和错误值

• VBA.TypeName(range("a1").Value)  

3）判断文本

• Application.IsText(range("a1"))

4）判断是否错误值

• VBA.IsError(range("a1").value)

5）数组判断

• VBA.IsArray(arr)

6）日期判断

• VBA.IsDate(range("a1"))

8、数据类型转换

类型装换函数：CBool,CByte,Ccur,CDate,CDbl,CDec,CInt,CLng,CSng,CStr,CVar

format( , ) 函数可将一种类型格式化显示为数字或文本类型

exp: format(234.5678,"0.00")

9、日期时间常用处理方式

1）常用转换：

• format(now,"yyyy-mm-dd")           如2002-12-11
• format(now,"yyyy年mm月dd天")   
• format(now,"yyyy年mm月dd天 h:mm:ss")
• format(now,"d-mmm-yy")      英文日期如19-Oct-02
• format(now,"d-mmmm-yy")   英文日期月份完整拼写 如19-October-02
• format(now,"aaaa")        中文日期星期几      如星期三
• format(now,"ddd")　　  英文日期星期几（简写）  如Sat
• format(now,"dddd")       英文日期星期几(完整写法) 如Saturday

2）日期时间的连接

日期连接 VBA.DateSerial(2011,10,1)

时间连接 VBA.TimeSerial(1,2,1)

3)  日期时间返回 year(now)

Year()函数、month()、day(）、hour()、VBA.,Minute()、second()

4) 日期时间计算datediff,dateadd

datediff("yyyy",d1,d2)

datediff("d",d1,d2) 等等。。注意datediff("q",d1,d2)  q为计算季度差，对年计算时需要参数为4个yyyy，计算分钟时参数为n dateadd("n",10,d1)

dateadd("d",10,d1) 加10天 等等 。。 注意计算分钟时参数为n dateadd("n",10,d1)，对年计算时需要参数为4个yyyy

5）制作一个简单计时器（application 的ontime函数）案例：注意设置doevents的意义为当前程序运行时允许其他程序运行，当公共变量k值改变则程序停止。

Option Explicit
Dim k
Public Sub clock()

    Dim x
    If k = 1 Then
        k = 0
    End
    End If
    With Range("c5").Font
        .Name = "Times New Roman"
        .FontStyle = "bold"
        .Size = 28
        .ColorIndex = 3
    End With
    With Range("c5").Interior
        .Pattern = xlPatternCrissCross
        .PatternColorIndex = 6
    End With
    
    Range("c5") = Format(Now, "h:mm:ss")
    Application.OnTime Now + TimeValue("00:00:01"), "clock"
    
    x = DoEvents  '此处设置终止
    
End Sub

Sub stopclock()
    k = 1
End Sub

Sub startclock()
    Call clock
End Sub

　效果：

10、随机抽取数据（换位）

 案例1：

Sub rndSelect()
    Dim arr
    Dim x, num, k As Integer, sr As String
    Range("c1:c10") = ""
    Range("a1:a10") = Application.Transpose(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
    
    For x = 1 To 10
        num = (Rnd() * (10 - x) + 1)  1   '1 表示除1取整
        Range("a1:a" & (10 - x + 1)).Interior.ColorIndex = xlNone
        Range("a" & num).Interior.ColorIndex = 6
        Range("c" & x) = Range("a" & num)
        
        sr = Range("a" & num)
        Range("a" & num) = Range("a" & (10 - x + 1))
        Range("a" & (10 - x + 1)) = sr
        Range("a" & (10 - x + 1)).Interior.ColorIndex = 3
    Next x
End Sub

　　

 案例2 ： A列20000行数据A1,A2....A20000

不重复随机抽取的三种方式：1、字典 2、换位法（换取的A列数据为字符串）3、换位法优化（添加一维数组辅助交换，索引为1~20000的数组，值为对应的索引，此时交换的值为integer型）

Sub rndict()
    '字典法
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    Dim arr, num As Integer, x As Integer, arr1(1 To 20000, 1 To 1) As String, t
    
    t = Timer
   
    arr = Range("a1:a20000")
    For x = 1 To 20000
100:
        num = Rnd() * (20000 - 1) + 1
        If d.exists(num) Then
            GoTo 100
        Else
            d(num) = ""
            arr1(x, 1) = arr(num, 1)
        End If
    Next x
    Range("c1:c20000") = ""
    Range("c1:c20000") = arr1
    [d65535].End(xlUp).Offset(1, 0) = Timer - t
    
 End Sub


Sub rndSel()
    ' 换位法,换字符串效率相对低
    Dim arr
    Dim x, num As Integer, arr1(1 To 20000, 1 To 1), sr As String, t
    t = Timer
    arr = Range("a1:a20000")
    For x = 1 To UBound(arr)
        num = (Rnd() * (20000 - x) + 1)  1
        arr1(x, 1) = arr(num, 1)
        
        sr = arr(num, 1)
        arr(num, 1) = arr(20000 - x + 1, 1)
        arr(20000 - x + 1, 1) = sr
    Next x
    
    Range("c1:c20000") = ""
    Range("c1:c20000") = arr1
    [d65535].End(xlUp).Offset(1, 0) = Timer - t
    
End Sub

Sub rndsel2()
    '换位法，添加辅助数字列，换数字 提高运行效率
    Dim arr
    Dim arr1(1 To 20000, 1 To 1), sr As String
    Dim x, num, arr2(1 To 20000) As Integer, t
    t = Timer
    arr = Range("a1:a20000")
    For x = 1 To 20000
        arr2(x) = x
    Next x
    For x = 1 To UBound(arr)
        num = (Rnd() * (20000 - x) + 1)
        arr1(x, 1) = arr(arr2(num), 1)
        
        sr = arr2(num)
        arr2(num) = arr2(20000 - x + 1)
        arr2(20000 - x + 1) = sr
    Next x
    Range("c1:c20000") = ""
    Range("c1:c20000") = arr1
    [d65535].End(xlUp).Offset(1, 0) = Timer - t
End Sub

　效果如下：

 明显发现采用第三种方式效率更高。