VBA小功能集合-判斷列內是否有重復值

1.判斷列內是否有重復值：

Dim arrT As Range
    Dim rng As Range
    Set arrT = Range("A:A")'判讀A列單元格
    For Each rng In arrT
        If rng = Empty Then'如果單元格為空就退出循環，否者循環65535次
            Exit For
        End If
        k = Application.CountIf(arrT, rng)’用CountIf函數掃描出重復值，跟excel的CountIF函數一樣
        If k > 1 Then
            rng.Select
            MsgBox rng.Address & " has duplicate data.'輸出提示信息，程序結束
            End
        End If
    Next

2.得到指定范圍內非空單元格的數量

Dim n As Long
n = Application.WorksheetFunction.CountA(Range("A:A")) 'Count of non-empty data in colum A

3.清空指定sheet頁

ActiveWorkbook.Worksheets("test").UsedRange.ClearContents

4.連接DB,並將從DB取得的集合放Sheet頁的指定行

    Set dbConn = CreateObject("ADODB.Connection")
    Set resSet = CreateObject("ADODB.Recordset")
    Rem ---------------------------------------
    strConn = "Provider=MSDAORA.1; user id=" & USER_ID & "; password=" & PASSWORD & "; data source = " & DATA_SOURCE & "; Persist Security Info=True"
    'Add reference: Microsoft ActiveX Data Objects 2.8 
    'Library,Microsoft ActiveX Data Objects Recordset 2.8 Library
    Rem------------------------------------------
   dbConn.Open strConn
    If dbConn.State <> adStateOpen Then
      MsgBox "DB Connect failed.Please Add reference: Microsoft ActiveX Data Objects 2.8 Library"
      connectDB = False
      End
    End If
    'select sql
    Set resSet = dbConn.Execute("select * from dual")
    
    If (resSet.BOF And resSet.EOF) Then
       dbConn.Close
       connectDB = False
       End
    End If
    
    'preset result
    Sheet1.Range("A2").CopyFromRecordset resSet
    'close connect
    dbConn.Close
    connectDB = True

5.使單元格不可編輯

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 2 Or Target.Column = 3 Or Target.Column = 4 Or Target.Column = 5 Or Target.Column = 6 Or Target.Column = 7 Or Target.Column = 8 Then
        If Cells(Target.Row, Target.Column) <> "" Then
            Beep
            Cells(Target.Row, 1).Offset(0, 0).Select
            'MsgBox Cells(Target.Row, Target.Column).Address & " cannot be selected and edited as it is a read-only cell", _
            'vbInformation, "Tool"
        End If
    End If
End Sub

6.check是不是文件夾或者文件

Public Function FileFolderExists(strFullPath As String) As Boolean

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
    On Error GoTo 0

End Function

7.文件copy

Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFile fromPath, toPath

8.創建和刪除文件夾

Set fs = CreateObject("scripting.filesystemobject")
fs.deleteFolder LocalFolderPath
fs.createFolder LocalFolderPath

9.用命令創建網絡連接盤符

    Dim objshell As Object
    Dim DosExec As Object
    Set objshell = CreateObject("wscript.shell")
    Set DosExec = objshell.Exec("cmd.exe /c " & "net use M: " & createPath)
    Set DosExec = Nothing
    Set objshell = Nothing