|
▎写在前面 都说写VBA像累积木，除了核心部分的循环逻辑思路，其余都是再堆砌代码。这篇文章就罗列一下我在写VBA程序中，常用的一些自定义函数。 ·列标相互转换 很多时候得到的列标是数字列标，需要把它转成英文列标的形式，比如下面的语句中col变量就是数字。 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如果不使用自定义函数，FSO的方式自带判断文件夹是否存在的方法 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·判断文件是否存在 方法一：Dir函数法 Function IsFileExists(ByVal strFileName As String) As Boolean If Dir(strFileName) <> Empty Then IsFileExists = True Else IsFileExists = False End IfEnd FunctionSub Run() If IsFileExists("D:\vba\abc.txt") = True Then ' 文件存在时的处理 MsgBox "文件存在！" Else ' 文件不存在时的处理 MsgBox "文件不存在！" End IfEnd Sub方法二：FSO对象方法 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 FunctionSub Run() If IsFileExists("D:\vba\abc.txt") = True Then ' 文件存在时的处理 MsgBox "文件存在！" Else ' 文件不存在时的处理 MsgBox "文件不存在！" End IfEnd Sub·判断WorkSheet是否存在 新建WorkSheet的时候，如果已经存在相同名字的WorkSheet，程序就会报错，一般先判断下某个WorkSheet是否存在，不存在的时候才进行新建操作。 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·对数组进行转置 通常数组转置都是借助工作表函数transpose，但是他的限制太多。 所以，如果元素过多，就是用自定义数组转置函数来解决。 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 LongSub 运用VBA判断计算机是否连网() If InternetGetConnectedState(0&, 0&) Then MsgBox "已连网" Else MsgBox "未连网" End IfEnd Sub |
|
|
