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 后参数：

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

区域中多格式：

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

　样式如下：

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

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

效果：

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

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

　效果：

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

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

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

案例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

　效果如下：

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

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