我的VBA自定义函数研习收获

weiyingde

Function ReadtxtFile(strPathName As String) As String
'VB格式化读取整个文本文件
    On Error GoTo Exit_Err
    Dim strFile As String
    Open strPathName For Input As #1
        ReadtxtFile = ""
        strFile = ""
        Do While Not EOF(1)
            Line Input #1, strFile ' = Input(1, #1)
            If ReadtxtFile = "" Then
                ReadtxtFile = strFile
            Else
                ReadtxtFile = ReadtxtFile & vbCrLf & strFile
            End If
        Loop
    Close #1
    Exit Function
Exit_Err:
    MsgBox Err.Description
    Exit Function
End Function


Sub Click()
   txt1 = ReadtxtFile("D:\H\Quick\常用.txt")
   MsgBox txt1
End Sub

weiyingde

' read函数' 读INI文件
strIniFile = ".example.ini"
strTemp = ReadINI(strIniFile, "Application", "Version")
MsgBox "Version = " & strTemp, vbInformation
Function ReadINI(FilePath, Bar, PrimaryKey)
Dim fso, sReadLine, i, j, ss
Set fso = CreateObject("Scripting.FileSystemObject")
Set IniFile = fso.opentextfile(FilePath, 1)
Do Until IniFile.atendofstream
    sReadLine = IniFile.readline
    If sReadLine = "" Then
        IniFile.skipline
    ElseIf Trim(sReadLine) = "[" & Bar & "]" Then       '找到小节名
        '查找该小节名下的键名
        Do Until IniFile.atendofstream
            sReadLine = IniFile.readline                '读取小节名后的行
            j = InStr(sReadLine, "=")
            If j > 0 Then                               '小节名后的文本行存在
                If InStr(Left(sReadLine, j), PrimaryKey) > 0 Then                       '从"="左边字符串找到键名
                    ss = Trim(Right(sReadLine, Len(sReadLine) - InStr(sReadLine, "="))) '读取等号后的部分
                    Exit Do
                End If
            End If
        Loop
    End If
Loop
IniFile.Close
Set fso = Nothing
ReadINI = ss
End Function

weiyingde

Function Wb打开(strWbName As String) As Boolean '检查指定工作簿是否打开
    Dim wbALL As Workbooks, wbOne As Workbook
    Dim IsOpn As Boolean
   
    Set wbALL = Excel.Application.Workbooks
    IsOpn = False
    For Each wbOne In wbALL
        If wbOne.Name = strWbName Then
            IsOpn = True
            Exit For
        End If
    Next
    Set wbALL = Nothing
    Wb打开 = IsOpn
End Function
Sub dk()
MsgBox Wb打开("政治问答题落实19.xlsm")
End Sub

weiyingde

获取单元格颜色的对应名称。
Function CellColor(rCell As Range, Optional ColorName As Boolean)
Dim strColor As String, iIndexNum As Integer
Select Case rCell.Interior.ColorIndex
     Case 1
      strColor = "Black"
      iIndexNum = 1
     Case 53
      strColor = "Brown"
      iIndexNum = 53
     Case 52
      strColor = "Olive Green"
      iIndexNum = 52
     Case 51
      strColor = "Dark Green"
      iIndexNum = 51
     Case 49
      strColor = "Dark Teal"
      iIndexNum = 49
     Case 11
      strColor = "Dark Blue"
      iIndexNum = 11
     Case 55
      strColor = "Indigo"
      iIndexNum = 55
     Case 56
      strColor = "Gray-80%"
      iIndexNum = 56
     Case 9
      strColor = "Dark Red"
      iIndexNum = 9
     Case 46
      strColor = "Orange"
      iIndexNum = 46
     Case 12
      strColor = "Dark Yellow"
      iIndexNum = 12
     Case 10
      strColor = "Green"
      iIndexNum = 10
     Case 14
      strColor = "Teal"
      iIndexNum = 14
     Case 5
      strColor = "Blue"
      iIndexNum = 5
     Case 47
      strColor = "Blue-Gray"
      iIndexNum = 47
     Case 16
      strColor = "Gray-50%"
      iIndexNum = 16
     Case 3
      strColor = "Red"
      iIndexNum = 3
     Case 45
      strColor = "Light Orange"
      iIndexNum = 45
     Case 43
      strColor = "Lime"
      iIndexNum = 43
     Case 50
      strColor = "Sea Green"
      iIndexNum = 50
     Case 42
      strColor = "Aqua"
      iIndexNum = 42
     Case 41
      strColor = "Light Blue"
      iIndexNum = 41
     Case 13
      strColor = "Violet"
      iIndexNum = 13
     Case 48
      strColor = "Gray-40%"
      iIndexNum = 48
     Case 7
      strColor = "Pink"
      iIndexNum = 7
     Case 44
      strColor = "Gold"
      iIndexNum = 44
     Case 6
      strColor = "Yellow"
      iIndexNum = 6
     Case 4
      strColor = "Bright Green"
      iIndexNum = 4
     Case 8
      strColor = "Turqoise"
      iIndexNum = 8
     Case 33
      strColor = "Sky Blue"
      iIndexNum = 33
     Case 54
      strColor = "Plum"
      iIndexNum = 54
     Case 15
      strColor = "Gray-25%"
      iIndexNum = 15
     Case 38
      strColor = "Rose"
      iIndexNum = 38
     Case 40
      strColor = "Tan"
      iIndexNum = 40
     Case 36
      strColor = "Light Yellow"
      iIndexNum = 36
     Case 35
      strColor = "Light Green"
      iIndexNum = 35
     Case 34
      strColor = "Light Turqoise"
      iIndexNum = 34
     Case 37
      strColor = "Pale Blue"
      iIndexNum = 37
     Case 39
      strColor = "Lavendar"
      iIndexNum = 39
     Case 2
      strColor = "White"
      iIndexNum = 2
    Case Else
      strColor = "自定义的颜色或者没有填充颜色."
  End Select
       If ColorName = True Or _
        strColor = "自定义的颜色或者没有填充颜色." Then
        CellColor = strColor
    Else
        CellColor = iIndexNum
    End If
End Function

weiyingde

数组排序。此程序为别人的帮助代码，当时没有记下其地址和姓名，再次说声抱歉。若再次遇见，吱个声。
Function Array_Sort(Array_, Key1&, order&)    '(Array_[将要排序的数组], Key1[数组(y,x)中x，像表格中的哪一列作关键字], Order[=1,升序;<>1,降序])
    Dim t, x&, y&, i&, j&, k&, xx&, yy&, tt&, AD&
    For i = 1 To 60
        On Error Resume Next
        Err.Clear
        tt = UBound(Array_, i)
        If Err.Number = 9 Then AD = i - 1: Exit For    'AD,数组维数
    Next
    If AD = 2 Then
        If Not (Key1 >= LBound(Array_, 2) And Key1 <= UBound(Array_, 2)) Then Exit Function
    ElseIf AD = 1 Then
        Array_ = Application.Transpose(Array_)
        Key1 = 1
    Else
        Exit Function
    End If
    y = LBound(Array_, 1): x = LBound(Array_, 2)
    yy = UBound(Array_): xx = UBound(Array_, 2)
    If order = 1 Then    '升序
        For i = y To yy - 1
            For j = i + 1 To yy
                If Array_(j, Key1) < Array_(i, Key1) Then    '冒泡排序法
                    For k = x To xx
                        t = Array_(j, k): Array_(j, k) = Array_(i, k): Array_(i, k) = t
                    Next
                End If
            Next
        Next
    Else    '降序
        For i = y To yy - 1
            For j = i + 1 To yy
                If Array_(j, Key1) > Array_(i, Key1) Then
                    For k = x To xx
                        t = Array_(j, k): Array_(j, k) = Array_(i, k): Array_(i, k) = t
                    Next
                End If
            Next
        Next
    End If
    If AD = 2 Then Array_Sort = Array_ Else Array_Sort = Application.Transpose(Array_)
End Function

weiyingde

注：此为不知名的作者的成果，特此申明。
Public Sub WaitTime(ByVal SpecSecond As Integer)
    Dim S1 As Date, S2 As Date, S As Long
    If SpecSecond <= 0 And SpecSecond > 60 Then Exit Sub
    S = 0
    S1 = Time()
    Do
        S2 = Time()
        If Second(S2) < Second(S1) Then
            '如果转到下一分钟，则以上一分钟的差加上下一分钟已过秒为间差
            S = (60 - Second(S1)) + Second(S2)
        Else
            '如果在相同分钟内，则直接相减即可
            S = Second(S2 - S1)
        End If
        DoEvents
    Loop While S < SpecSecond
End Sub

weiyingde

注：此亦为不知名的作者的成果。函数作用:计算20000余个汉字的笔画Function STROCK(CHNCHR As String) STR1 = "与之及夨扌3,尣乏以夃巨4,卍歺伋印回夗5,仮似吸攰6,尦巫镸飏7,乸尩芈受烎鼡8,巻拏叟埩婙9,弬彧袅欫镹琤訚10,彪兞将晘梡祡営惸掽描毮逽镺匓碀11,"
    STR2 = "晩鹀黄僆嗒搑斞斱殾溬溾遚镻飱黾廐12,媐戡琞缙臦勨厯奥掴槩滫潃舝蔜蜀澕诤踭13,怄歌熓獒僶儁墟寿嶑憈撗敻暮昵毃氁獡裦鄳镌閰养铮14,"
    STR3 = "婵摾晔槪誾憴懊擑渑澫濈濍縙諩錓镼餝15,碛膐輤錻阛韰厳殩濭篹襃餴鴱鼋龟鵖16,燛簔闀謰哗鎹鎾饂黝鼀鵧兤剩17,藔羀臩荠鯐鹀斋夓瀢绳繱蝇譃鏅鏎鞳顝鲞鹱鼃18,"
    STR3 = "儱陇馦齁匶襕譝譢鐅镽騪魓鯺鰙鼅鼅19,嚺蘤咙垄宠巃徿拢泷璺舋茏腾咸櫹櫹疉疉灶灶鐽鐽饏饏騿騿鬕鬕驆驆赢20,昽栊爖珑辟闦鷌龡龡谪谪镾镾鷝鷝鷨龝21,眬眬砻砻竉竉龢讉鱋鷬鷵鼆22,"
    STR4 = "爢爢巅巅櫷櫷笼笼聋聋蠪蠪袭袭雠雠鬛鬛麟麟蠲鱦鱪鳖骡23,爤爤虁虁詟贚碱纛讙鱰鹱鼍24,鑨鬬鸂鑶鱱鼊25,斗虌讝阄26,驡龞27,鱹28,龖36,齉37,靐39,龘51"
    STR1234 = STR1 + STR2 + STR3 + STR4
    On Error Resume Next
    N = WorksheetFunction.Find(CHNCHR, STR1234)
    If N > 0 Then
        CN = "0"
        For i = N To Len(STR1234)
            CHAR0 = Mid(STR1234, i, 1)
            If CHAR0 <> "," Then
                If Asc(CHAR0) <= 57 And Asc(CHAR0) > 47 Then
                    CN = CVar(CN) * 10 + CVar(CHAR0)
                End If
            Else
                STROCK = CInt(CN)
                Exit Function
            End If
        Next i
    Else
        Workbooks.Add
        tembook = ActiveWorkbook.Name
        STR0 = "一丁万不且丞丣并临丵干亁乱僊僵亸偿儭龎龏龑龒龓儾囔圞灥囖纞厵滟灪爩龗齾"
        For i = 1 To 35
            Workbooks(tembook).Sheets(1).Range("A" + Trim(i + 1)).Value = i
            Workbooks(tembook).Sheets(1).Range("B" + Trim(i + 1)).Value = Mid(STR0, i, 1)
        Next i
        Workbooks(tembook).Sheets(1).Range("B" + Trim(i + 1)).Value = CHNCHR
        Workbooks(tembook).Sheets(1).Range("A2:b37").Sort Key1
        = Range("B2"), Order1
        = xlAscending, Header
        = xlGuess, OrderCustom
        = 1, MatchCase
        = False, Orientation
        = xlTopToBottom, _
          SortMethod
        = xlStroke, DataOption1
        = xlSortNormal
        STROCK = (Workbooks(tembook).Sheets(1).Range("A2").End(xlDown).Value)
    End If
    Application.DisplayAlerts = False
    Workbooks(tembook).Close
    Application.DisplayAlerts = True
End Function

weiyingde

继续，亦为别人成果。
.函数作用:导出VBA Project代码
Public Function ExportCode()
    For Each theMod In ThisWorkbook.VBProject.VBComponents
        theMod.Export "the" & theMod.Name & ".bas"
    Next
End Function


函数作用:导入VBA Project代码Function ImportCode1()
    'Dim theMod As VBIDE.VBComponent
    For Each theMod In ThisWorkbook.VBProject.VBComponents
        With theMod.CodeModule
            '             .AddFromFile "c:\windows\desktop\index_Y.txt"
            .AddFromFile "the" & .Parent.Name & ".bas"
        End With
    Next
End Function

获取vbproject引用项目Sub ListReferences()   
For Each Ref In ThisWorkbook.VBProject.References      
i = i + 1        
Cells(i, 1) = Ref.Name        
Cells(i, 2) = Ref.GUID      
Cells(i, 3) = Ref.Major        
Cells(i, 4) = Ref.Minor      
Cells(i, 5) = Ref.FullPath        
Cells(i, 6) = Ref.Description   
Next Ref
End Sub

weiyingde

继续为别人成果。
函数作用:将一个数组按升序排列
Function sx(x()) As Variant()
    Dim i As Integer, j As Integer, a, d()
    ReDim sx(LBound(x) To UBound(x)), d(LBound(x) To UBound(x))
    d = x
    If LBound(x) = UBound(x) Then
        sx = d
        Exit Function
    End If
    For i = LBound(x) To UBound(x) - 1
        For j = i + 1 To UBound(x)
            If d(j) < d(i) Then
                a = d(j)
                d(j) = d(i)
                d(i) = a
            End If
        Next
    Next
    sx = d
End Function

函数作用:将一个数组按降序排列
Function sx(x()) As Variant()
    Dim i As Integer, j As Integer, a, d()
    ReDim sx(LBound(x) To UBound(x)), d(LBound(x) To UBound(x))
    d = x
    If LBound(x) = UBound(x) Then
        sx = d
        Exit Function
    End If
    For i = LBound(x) To UBound(x) - 1
        For j = i + 1 To UBound(x)
            If d(j) > d(i) Then
                a = d(j)
                d(j) = d(i)
                d(i) = a
            End If
        Next
    Next
    sx = d
End Function

weiyingde

批量替换字符
Function ArrReplace(myStr As String) As String
    Dim i%
    Dim arr1, arr2
    arr1 = Array("A", "B", "C")
    arr2 = Array("11", "12", "13")
    For i = LBound(arr1) To UBound(arr2)
        myStr = WorksheetFunction.Substitute(myStr, arr1(i), arr2(i))
    Next
    ArrReplace = myStr
End Functio