【原】【源碼分享】VBA中一些常用的自定義函數(shù)

VBA說(shuō) 2021-01-17

展開全文

▎寫在前面

都說(shuō)寫VBA像累積木,，除了核心部分的循環(huán)邏輯思路,，其余都是再堆砌代碼。這篇文章就羅列一下我在寫VBA程序中,，常用的一些自定義函數(shù),。

·列標(biāo)相互轉(zhuǎn)換

很多時(shí)候得到的列標(biāo)是數(shù)字列標(biāo)，需要把它轉(zhuǎn)成英文列標(biāo)的形式,，比如下面的語(yǔ)句中col變量就是數(shù)字,。

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

但是如果我們需要這個(gè)數(shù)字所對(duì)應(yīng)的英文列標(biāo)，這個(gè)時(shí)候就需要下面的自定義函數(shù)進(jìn)行便捷轉(zhuǎn)化,。

自定義函數(shù)代碼：

'列數(shù)轉(zhuǎn)字母Function CNtoW(ByVal num As Long) As String CNtoW = Replace(Cells(1, num).Address(False, False), "1", "")End Function'字母轉(zhuǎn)列數(shù)Function CWtoN(ByVal AB As String) As Long CWtoN = Range("a1:" & AB & "1").Cells.CountEnd Function

代碼使用實(shí)例：

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

·判斷文件夾是否存在

往往存儲(chǔ)運(yùn)行結(jié)果需要建文件夾的時(shí)候,，需要首先判斷下文件夾是否存在，如果不判斷直接新建,，程序會(huì)報(bào)錯(cuò),。

自定義函數(shù)代碼：

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

如果不使用自定義函數(shù),，F(xiàn)SO的方式自帶判斷文件夾是否存在的方法

Sub 新建文件夾() PathG = "D:\folder1" Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(PathG) = True Then fso.getfolder(PathG).Delete '//刪除文件夾 MkDir PathG '//創(chuàng)建文件夾 Else MkDir PathG '//創(chuàng)建文件夾 End IfEnd Sub

·判斷文件是否存在

方法一：Dir函數(shù)法

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 ' 文件存在時(shí)的處理 MsgBox "文件存在！" Else ' 文件不存在時(shí)的處理 MsgBox "文件不存在,！" End IfEnd Sub

方法二：FSO對(duì)象方法

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 ' 文件存在時(shí)的處理 MsgBox "文件存在,！" Else ' 文件不存在時(shí)的處理 MsgBox "文件不存在！" End IfEnd Sub

·判斷WorkSheet是否存在

新建WorkSheet的時(shí)候,，如果已經(jīng)存在相同名字的WorkSheet,，程序就會(huì)報(bào)錯(cuò)，一般先判斷下某個(gè)WorkSheet是否存在,，不存在的時(shí)候才進(jìn)行新建操作,。

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

·對(duì)數(shù)組進(jìn)行轉(zhuǎn)置

通常數(shù)組轉(zhuǎn)置都是借助工作表函數(shù)transpose，但是他的限制太多,。
1.數(shù)量不能超過(guò)65536
2.數(shù)組中元素的長(zhǎng)度不能超過(guò)255

所以,，如果元素過(guò)多，就是用自定義數(shù)組轉(zhuǎn)置函數(shù)來(lái)解決,。

Function Transpose2(arr As Variant)'轉(zhuǎn)置核心代碼 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

·判斷本機(jī)是否聯(lián)網(wǎng)

Private Declare Function InternetGetConnectedState Lib "wininet.dll" _ (ByRef dwFlags As Long, ByVal dwReserved As Long) As Long

Sub 運(yùn)用VBA判斷計(jì)算機(jī)是否連網(wǎng)() If InternetGetConnectedState(0&, 0&) Then MsgBox "已連網(wǎng)" Else MsgBox "未連網(wǎng)" End IfEnd Sub