【源码分享】VBA中一些常用的自定义函数

col = Cells(1, Columns.Count).End(xlToLeft).Column

'列数转字母Function CNtoW(ByVal num As Long) As String    CNtoW = Replace(Cells(1, num).Address(False, False), "1", "")End Function'字母转列数Function CWtoN(ByVal AB As String) As Long    CWtoN = Range("a1:" & AB & "1").Cells.CountEnd Function

Sub test()    col = Cells(1, Columns.Count).End(xlToLeft).Column    Range("a1:" & CNtoW(col) & 1).SelectEnd Sub

Public Function FileFolderExists(ByVal strFullPath As String) As Boolean    If Not Dir(strFullPath, vbDirectory) = vbNullString Then    FileFolderExists = True    Else     FileFolderExists = False    End IfEnd Function

Sub 新建文件夹()    PathG = "D:\folder1"    Set fso = CreateObject("Scripting.FileSystemObject")    If fso.FolderExists(PathG) = True Then        fso.getfolder(PathG).Delete '//删除文件夹        MkDir PathG '//创建文件夹    Else        MkDir PathG '//创建文件夹    End IfEnd Sub

Function IsFileExists(ByVal strFileName As String) As Boolean    If Dir(strFileName) <> Empty Then        IsFileExists = True    Else        IsFileExists = False    End IfEnd Function
Sub Run()    If IsFileExists("D:\vba\abc.txt") = True Then        ' 文件存在时的处理        MsgBox "文件存在！"    Else        ' 文件不存在时的处理        MsgBox "文件不存在！"    End IfEnd Sub

Function IsFileExists(ByVal strFileName As String) As Boolean    Dim objFileSystem As Object        Set objFileSystem = CreateObject("Scripting.FileSystemObject")    If objFileSystem.fileExists(strFileName) = True Then        IsFileExists = True    Else        IsFileExists = False    End IfEnd Function
Sub Run()    If IsFileExists("D:\vba\abc.txt") = True Then        ' 文件存在时的处理        MsgBox "文件存在！"    Else        ' 文件不存在时的处理        MsgBox "文件不存在！"    End IfEnd Sub

Sub 新建sheet()    If SheetExists("表一") = False Then        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "表一"    End IfEnd SubFunction SheetExists(sname) As Boolean    Dim x As Object    On Error Resume Next    Set x = ActiveWorkbook.Sheets(sname)    If Err = 0 Then SheetExists = True _Else SheetExists = FalseEnd Function

Function Transpose2(arr As Variant)'转置核心代码    Dim brr(), i, j, n    n = NumberOfArrayDimensions(arr)    If n = 1 Then        ReDim brr(LBound(arr) To UBound(arr), 1 To 1)        For i = LBound(arr) To UBound(arr)            brr(i, 1) = arr(i)        Next    Else        ReDim brr(LBound(arr, 2) To UBound(arr, 2), LBound(arr) To UBound(arr))        For i = LBound(arr) To UBound(arr)            For j = LBound(arr, 2) To UBound(arr, 2)                brr(j, i) = arr(i, j)            Next        Next    End If    Transpose2 = brrEnd FunctionPublic Function NumberOfArrayDimensions(arr As Variant) As Integer    Dim Ndx As Integer    Dim Res As Integer    On Error Resume Next    Do        Ndx = Ndx + 1        Res = UBound(arr, Ndx)    Loop Until Err.Number <> 0    NumberOfArrayDimensions = Ndx - 1End Function

Private Declare Function InternetGetConnectedState Lib "wininet.dll" _    (ByRef dwFlags As Long, ByVal dwReserved As Long) As Long
Sub 运用VBA判断计算机是否连网()    If InternetGetConnectedState(0&, 0&) Then        MsgBox "已连网"    Else        MsgBox "未连网"    End IfEnd Sub