自用Excel VBA函数整理 part2

执行ADO SQL（参数可为1维Array或Range）： 

Public Function ExecuteSQLCmd(conn As ADODB.Connection, cmd As ADODB.Command, ByRef rowsAffected, Optional paramArrayOrRng) As ADODB.Recordset
    If cmd.Parameters.Count > 0 Then
        For i = cmd.Parameters.Count - 1 To 0 Step -1
            cmd.Parameters.Delete i
        Next i
    End If
    cmd.ActiveConnection = conn
    
    If Not (IsMissing(paramArrayOrRng) Or IsEmpty(paramArrayOrRng)) Then
        cmd.Prepared = True
        If IsObject(paramArrayOrRng) Then
            If TypeName(paramArrayOrRng) = "Range" Then
                For Each cell In paramArrayOrRng.Cells
                    v = cell.value
                    cmd.Parameters.Append CreateDbParameter(v)
                Next cell
            Else    'could be Collection etc.
                For Each cell In paramArrayOrRng
                    v = cell.value
                    cmd.Parameters.Append CreateDbParameter(v)
                Next cell
            End If
        ElseIf IsArray(paramArrayOrRng) Then
            For Each v In paramArrayOrRng
                cmd.Parameters.Append CreateDbParameter(v)
            Next v
        Else
            cmd.Parameters.Append CreateDbParameter(paramArrayOrRng)
        End If
    Else
        cmd.Prepared = False
    End If
    
    Dim rs As ADODB.Recordset
    Set rs = cmd.Execute(ra)
    Set ExecuteSQLCmd = rs
End Function

Private Function CreateDbParameter(v) As ADODB.Parameter
    t = ADODB.DataTypeEnum.adVariant
    Select Case TypeName(v)
        Case "String"
            t = ADODB.DataTypeEnum.adVarChar
        Case "Integer"
            t = ADODB.DataTypeEnum.adInteger
        Case "Double"
            t = ADODB.DataTypeEnum.adDouble
        Case "Date"
            t = ADODB.DataTypeEnum.adDate
    End Select
    
    Dim p As New ADODB.Parameter
    p.Type = t
    If t = ADODB.DataTypeEnum.adVarChar Then p.Size = Len(v) * 2 'for non-ascii
    p.value = IIf(IsEmpty(v), Null, v)
    p.Direction = adParamInput
    Set CreateDbParameter = p
End Function

Public Function ExecuteSQL(conn As ADODB.Connection, sqlTxt, ByRef rowsAffected, Optional paramArrayOrRng) As ADODB.Recordset
    Dim cmd As New ADODB.Command
    cmd.CommandText = sqlTxt
    
    Set ExecuteSQL = ExecuteSQLCmd(conn, cmd, ra, paramArrayOrRng)
End Function

Public Function ExecuteSP(conn As ADODB.Connection, spName, ByRef rowsAffected, Optional paramArrayOrRng) As ADODB.Recordset
    Dim cmd As New ADODB.Command
    cmd.CommandText = spName
    cmd.CommandType = ADODB.adCmdStoredProc
    
    Set ExecuteSP = ExecuteSQLCmd(conn, cmd, ra, paramArrayOrRng)
End Function

Public Sub CopyFromRecordset(cellTopLeft As Range, rs As Recordset)
    For i = 0 To (rs.Fields.Count - 1)
        cellTopLeft.Offset(0, i) = rs.Fields(i).Name
    Next
    cellTopLeft.Offset(1, 0).CopyFromRecordset rs
End Sub

Public Sub CopyRecordRow(cell As Range, rs As Recordset, Optional colStart, Optional colEnd)
    l = IIf(IsMissing(colStart), 0, colStart)
    u = IIf(IsMissing(colEnd), rs.Fields.Count - 1, colEnd)
    For i = l To u
        cell.Offset(0, i - l) = rs(i)
    Next
End Sub

 

代替ATP的WEEKNUM()：（另，兼容ISO的实现见这里；还有如何较完美的Register UDF参考）

Public Function SysWeekNum(dat, Optional firstDayOfWeek As VbDayOfWeek = vbMonday) As Integer
    SysWeekNum = DatePart("ww", dat, firstDayOfWeek, vbFirstJan1)
End Function

Public Function ActWeekNum(dat, Optional firstDayOfWeek As VbDayOfWeek = vbMonday) As Integer
    jan1 = DateSerial(Year(dat), 1, 1)
    days = dat - jan1 + Weekday(jan1, firstDayOfWeek)
    ActWeekNum = (days - 1) \ 7 + 1
End Function

 

Application.Calculation，Application.ScreenUpdating，Application.EnableEvents，Application.DisplayAlerts：

Public Sub SetUpdating(calculation As Boolean, Optional screenUpdate = True, Optional events = True, Optional alerts = True)
    If calculation Then
        Application.calculation = xlCalculationAutomatic
    Else
        Application.calculation = xlCalculationManual
    End If
    
    Application.ScreenUpdating = screenUpdate
    Application.EnableEvents = events
    Application.DisplayAlerts = alerts
End Sub

 

Regular Expression (可作为UDF)

Public Function RegExpTest(str, pattern, Optional ignoreCase = True, Optional firstMatch = False) As Boolean
    Dim RE As New RegExp
    RE.ignoreCase = ignoreCase
    RE.Global = Not firstMatch
    RE.pattern = pattern
    RegExpTest = RE.Test(str)
    Set RE = Nothing
End Function

Public Function RegExpReplace(str, pattern, replace, Optional ignoreCase = True, Optional firstMatch = False) As String
    Dim RE As New RegExp
    RE.ignoreCase = ignoreCase
    RE.Global = Not firstMatch
    RE.pattern = pattern
    RE.MultiLine = True
    RegExpReplace = RE.replace(str, replace)
    Set RE = Nothing
End Function

Public Function RegExpFindFirst(str, pattern, Optional startPos = 1, Optional ignoreCase = True) As Integer
    Dim RE As New RegExp
    RE.ignoreCase = ignoreCase
    RE.Global = False
    RE.pattern = pattern
    srcStr = IIf(startPos = 1, str, Right(str, Len(str) - startPos + 1))
    
    Dim matches As MatchCollection
    Set matches = RE.Execute(srcStr)
    If matches.Count = 0 Then
        RegExpFindFirst = 0
    Else
        RegExpFindFirst = matches.Item(0).FirstIndex + 1
    End If
    Set RE = Nothing
End Function

 

1纬数组相关函数：

Public Function ArrayRange(head, tail, Optional step = 1)
    u = WorksheetFunction.Floor(Abs(tail - head) / step, 1)
    Dim ret(): ReDim ret(0 To u)
    For i = 0 To u
        ret(i) = head + step * i
    Next i
    ArrayRange = ret
End Function

Public Function ArrayLen(arr)
    If IsArray(arr) Then
        ArrayLen = UBound(arr) - LBound(arr) + 1
    Else
        ArrayLen = 1
    End If
End Function

Public Function ArrayJoinV(ParamArray arr())
    l = LBound(arr): u = UBound(arr): n = u - 1 + 1
    Dim tmp(): ReDim tmp(0 To n): n = 0
    For i = l To u
        tmp(n) = arr(i): n = n + 1
    Next i
    ArrayJoinV = ArrayJoin(tmp) 'param array cannot be directly used here..
End Function

Public Function ArrayJoin(arr As Variant)
    Dim ret()
    If IsArray(arr) Then    'arr expected to be array of arrays
        l = LBound(arr): u = UBound(arr): n = 0
        For i = l To u
            n = n + ArrayLen(arr(i))
        Next i
        ReDim ret(0 To n - 1): n = 0
        For i = l To u
            elem = arr(i)
            If IsArray(elem) Then
                For j = LBound(elem) To UBound(elem)
                    ret(n) = elem(j): n = n + 1
                Next j
            Else
                ret(n) = elem: n = n + 1
            End If
        Next i
        ArrayJoin = ret
    Else
        ReDim ret(0 To 0): ret(0) = arr
        ArrayJoin = ret
    End If
End Function

 

If an item is 'In' a collection

Public Function WithIn(item, list) As Boolean
    ret = False
    If TypeName(item) = TypeName(list) Then
        If item = list Then ret = True
    ElseIf IsArray(list) Or TypeName(list) = "Collection" Or TypeName(list) = "Dictionary" Then
        For Each i In list
            If item = i Then
                ret = True
                Exit For
            End If
        Next
    End If
    WithIn = ret
End Function

  

BubbleSort an array：（NlogN的排序在VBA里面实在不好实现，先用这个顶上）

Public Sub BubbleSort(arr, l, u)
    If Not IsArray(arr) Then Exit Sub
    sorted = False
    Do While Not sorted
        sorted = True
        For i = l To (u - 1)
            If arr(i) > arr(i + 1) Then
                sorted = False
                tmp = arr(i + 1)
                arr(i + 1) = arr(i)
                arr(i) = tmp
            End If
        Next i
    Loop
End Sub

 

FilePicker和FolderPicker，读取文件夹内文件名：

Public Function PickerDialog(Optional fileDialogType As MsoFileDialogType = msoFileDialogFilePicker) As String
    Dim fdlg As FileDialog
    Set fdlg = Application.FileDialog(fileDialogType)
    If fdlg.Show = -1 Then
        PickerDialog = fdlg.SelectedItems(1)
    Else
        PickerDialog = ""
    End If
    Set fdlg = Nothing
End Function

Public Function ListFilesInFolder(folderPath, Optional ext) As Collection
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    Dim files As New Collection
    fname = Dir(folderPath, vbDirectory)
    Do While fname <> ""
        If fname <> "." And fname <> ".." Then
            If IsMissing(ext) Then
                files.Add fname
            Else
                If fname Like "*" & ext Then files.Add fname
            End If
        End If
        fname = Dir()
    Loop
    Set ListFilesInFolder = files
End Function

 

打开工作表，或返回已打开的同名工作表：

Public Function OpenWorkbook(filePath, Optional updateLink = False, Optional focusThisBook = True) As Workbook
    parts = Split(filePath, "\")
    fname = parts(UBound(parts))
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name Like fname Then
            Set OpenWorkbook = wb
            Exit Function
        End If
    Next
    If updateLink = False Then
        Set OpenWorkbook = Workbooks.Open(filePath, 0)
    Else
        Set OpenWorkbook = Workbooks.Open(filePath)
    End If
    If focusThisBook Then ThisWorkbook.activate
End Function

 

Enum to help with ColorIndex and SchemeColor:

Public Enum ColorIdx
'The color enumeration is handy for use with any object that has a ColorIndex or SchemeColor property;
'just add 7 to ColorIndex to convert to SchemeColor.
    Aqua = 42
    Black = 1
    Blue = 5
    BlueGray = 47
    BrightGreen = 4
    Brown = 53
    Cream = 19
    DarkBlue = 11
    DarkGreen = 51
    DarkPurple = 21
    DarkRed = 9
    DarkTeal = 49
    DarkYellow = 12
    Gold = 44
    Gray25 = 15
    Gray40 = 48
    Gray50 = 16
    Gray80 = 56
    Green = 10
    Indigo = 55
    Lavender = 39
    LightBlue = 41
    LightGreen = 35
    LightLavender = 24
    LightOrange = 45
    LightTurquoise = 20
    LightYellow = 36
    Lime = 43
    NavyBlue = 23
    OliveGreen = 52
    Orange = 46
    PaleBlue = 37
    Pink = 7
    Plum = 18
    PowderBlue = 17
    Red = 3
    Rose = 38
    Salmon = 22
    SeaGreen = 50
    SkyBlue = 33
    Tan = 40
    Teal = 14
    Turquoise = 8
    Violet = 13
    White = 2
    Yellow = 6
'    Blue = 32 'duplicate of 5
'    DarkBlue = 25 'duplicate of 11
'    DarkRed = 30 'duplicate of 9
'    LightTurquoise = 34 'duplicate of 20
'    Pink = 26 'duplicate of 7
'    Plum = 54 'duplicate of 18
'    Teal = 31 'duplicate of 14
'    Turquoise = 28 'duplicate of 8
'    Violet = 29 'duplicate of 13
'    Yellow = 27 'duplicate of 6
End Enum

Public Function ToSchemeColor(idx As Integer) As Integer
    ToSchemeColor = idx + 7
End Function

 

代码创建一个Camera：

Public Sub CopyCamera(srcRng As Range, destRng As Range, Optional cameraName = "")
    srcRng.CopyPicture
    destRng.PasteSpecial
    
    Dim pic As Picture: Set pic = Selection
    pic.Formula = StrFormat("'{0}'!{1}", srcRng.Worksheet.Name, srcRng.Address)
    
    If Not IsMissing(cameraName) And cameraName <> "" Then
        pic.Name = cameraName
    End If
End Sub