Excel VBA常用代碼總結1

做了幾個月的Excel VBA，總結了一些常用的代碼，我平時編程的時候參考這些代碼，基本可以完成大部分的工作，現在共享出來供大家參考。

說明：本文為大大佐原創，但部分代碼也是參考百度得來。 

• 改變背景色

Range("A1").Interior.ColorIndex = xlNone

 ColorIndex一覽

• 改變文字顏色

 

Range("A1").Font.ColorIndex = 1

 

• 獲取單元格

 

Cells(1, 2)
Range("H7")

 

• 獲取范圍

 

Range(Cells(2, 3), Cells(4, 5))
Range("a1:c3")
'用快捷記號引用單元格
Worksheets("Sheet1").[A1:B5]

 

• 選中某sheet

 

Set NewSheet = Sheets("sheet1")
NewSheet.Select

 

• 選中或激活某單元格

 

'“Range”對象的的Select方法可以選擇一個或多個單元格，而Activate方法可以指定某一個單元格為活動單元格。
'下面的代碼首先選擇A1:E10區域，同時激活D4單元格：
       Range("a1:e10").Select
       Range("d4:e5").Activate
'而對於下面的代碼：
       Range("a1:e10").Select
       Range("f11:g15").Activate
'由於區域A1:E10和F11:G15沒有公共區域，將最終選擇F11:G15，並激活F11單元格。

 

• 獲得文檔的路徑和文件名

 

ActiveWorkbook.Path　　　　'路徑
ActiveWorkbook.Name　　　'名稱
ActiveWorkbook.FullName　 '路徑＋名稱
'或將ActiveWorkbook換成thisworkbook

 

• 隱藏文檔

 

Application.Visible = False

 

• 禁止屏幕更新

 

Application.ScreenUpdating = False

 

• 禁止顯示提示和警告消息

 

Application.DisplayAlerts = False

 

• 文件夾做成

strPath = "C:\temp\"
MkDir strPath

 

• 狀態欄文字表示

Application.StatusBar = "計算中"

 

• 雙擊單元格內容變換

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If  (Target.Cells.Row >= 5 And Target.Cells.Row <= 8) Then
        If Target.Cells.Value = "●" Then
            Target.Cells.Value = ""
        Else
            Target.Cells.Value = "●"
        End If
        Cancel = True
    End If
End Sub

 

• 文件夾選擇框方法1

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "文件", 0, 0)
If Not objFolder Is Nothing 
Then path= objFolder.self.Path & "\"
end if
Set objFolder = Nothing
Set objShell = Nothing

 

• 文件夾選擇框方法2（推薦）

 Public Function ChooseFolder() As String
  Dim dlgOpen     As FileDialog
  Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
  With dlgOpen
    .InitialFileName = ThisWorkbook.path & "\"
    If .Show = -1 Then
            ChooseFolder = .SelectedItems(1)
    End If
  End With
  Set dlgOpen = Nothing
  End Function

'使用方法例：
Dim path As String
path = ChooseFolder()
If path <> "" Then
    MsgBox "open folder"
End If

 

• 文件選擇框方法

  Public Function ChooseOneFile(Optional TitleStr As String = "Please choose a file", Optional TypesDec As String = "*.*", Optional Exten As String = "*.*") As String
  Dim dlgOpen     As FileDialog
  Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
  With dlgOpen
          .Title = TitleStr
          .Filters.Clear     
          .Filters.Add TypesDec, Exten    
          .AllowMultiSelect = False       
          .InitialFileName = ThisWorkbook.Path
          If .Show = -1 Then
          '   .AllowMultiSelect   =   True               
          '   For   Each   vrtSelectedItem   In   .SelectedItems
          '   MsgBox   "Path   name:   "   &   vrtSelectedItem
          '   Next   vrtSelectedItem
          ChooseOneFile = .SelectedItems(1)             
          End If
  End With
  Set dlgOpen = Nothing
  End Function

 

• 某列到關鍵字為止循環方法1(假設關鍵字是end)

Set CurrentCell = Range("A1")
Do While CurrentCell.Value <> "end"
……
Set CurrentCell = CurrentCell.Offset(1, 0)
Loop

 

• 某列到關鍵字為止循環方法2(假設關鍵字是空字符串)

i = StartRow
Do While Cells(i, 1) <> ""
……
i = i + 1
Loop

 

• "For Each...Next 循環(知道確切邊界)

For Each c In Worksheets("Sheet1").Range("A1:D10").Cells
　　If Abs(c.Value) < 0.01 Then c.Value = 0
Next

 

• "For Each...Next 循環(不知道確切邊界),在活動單元格周圍的區域內循環

For Each c In ActiveCell.CurrentRegion.Cells
    If Abs(c.Value) < 0.01 Then c.Value = 0
Next

 

 

• 某列有數據的最末行的行數的取得(中間不能有空行)

 

lonRow=1
Do While Trim(Cells(lonRow, ２).Value) <> ""
  lonRow = lonRow + 1
Loop
lonRow11 = lonRow11 - 1

 

• A列有數據的最末行的行數的取得 另一種方法

 

Range("Ａ65536").End(xlUp).Row

 

• 將文字復制到剪貼板

Dim MyData As DataObject
Set MyData = New DataObject
MyData.SetText Range("H7").Value
MyData.PutInClipboard

 

• 取得路徑中的文件名

Private Function GetFileName(ByVal s As String)
    Dim sname() As String
    sname = Split(s, "\")
    GetFileName = sname(UBound(sname))
End Function

 

• 取得路徑中的路徑名

Private Function GetPathName(ByVal s As String)
    intFileNameStart = InStrRev(s, "\")
    GetPathName = Mid(s, 1, intFileNameStart)
End Function

 

• 由模板sheet拷貝做成一個新的sheet

ThisWorkbook.Worksheets("template").Copy After:=ThisWorkbook.Worksheets(Sheets.Count)
Set doc_s = ThisWorkbook.Worksheets(Sheets.Count)
doc_s.Name = "newsheetname" & Format(Now, "yyyyMMddhhmmss")

 

• 選中當列的最后一個有內容的單元格(中間不能有空行)

'刪除B3開始到B列最后一個有內容的單元格為止的所有內容
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

 

• 常量定義

Private Const StartRow                  As Integer = 3

 

• 判斷sheet是否存在

Private Function IsWorksheet(ByVal strSeetName As String) As Boolean   
    On Error GoTo ErrHandle
    Dim blnRet As Boolean
    blnRet = IsNull(Worksheets(strSeetName))
    IsWorksheet = True
    Exit Function
ErrHandle:
    IsWorksheet = False
End Function

 

• 向單元格中寫入公式

Worksheets("Sheet1").Range("D6").Formula = "=SUM(D2:D5)"

 

• 引用命名單元格區域

Range("MyBook.xls!MyRange")
Range("[Report.xls]Sheet1!Sales"

 

• 選定命名的單元格區域

Application.Goto Reference:="MyBook.xls!MyRange"
'或者
worksheets("sheetname").range("rangename").select
Selection.ClearContents

 

• 使用Dictionary

'使用Dictionary需要添加參照Microsoft Scripting Runtime

Dim dic  As New Dictionary 
dic.Add "Table", "Cards"     '前面是 Key 后面是 Value
dic.Add "Serial", "serialno"
dic.Add "Number", "surface"  

MsgBox dic.Item("Table")    '由Key取得Value
dic.Exists("Table")                '判斷某Key是否存在

 

• 將EXCEL表格中的兩列表格插入到一個Dictionary中

'函數：在ws工作表中，從iStartRow行開始到沒有數據為止，把iKeyCol列和iKeyCol右一列插入到一個字典中，並返回字典。
Public Function SetDic(ws As Worksheet, iStartRow, iKeyCol As Integer) As Dictionary

    Dim dic As New Dictionary
    Dim i As Integer

    i = iStartRow
    Do Until ws.Cells(i, iRuleCol).Value = ""
    
        If Not dic.Exists(ws.Cells(i, iKeyCol).Value) Then
            dic.Add ws.Cells(i, iKeyCol).Value, ws.Cells(i, iKeyCol + 1).Value
        End If
    
        i = i + 1
    Loop
    
    Set SetDic = dic
    
End Function

• 判斷文件夾或文件是否存在

'文件夾
If Dir("C:\aaa", vbDirectory) = "" Then 
MkDir "C:\aaa" 
End If 

'文件
If Dir("C:\aaa\1.txt") = "" Then 
msgbox "文件C:\aaa\1.txt不存在" 
end if 

 

• 一次注釋多行

    視圖---工具欄---編輯   調出編輯工具欄，工具欄上有個“設置注釋塊” 和 “解除注釋快”

• 打開文件並將文件賦予到第一個參數wb中

'注意，這里的path是文件的完整路徑，包括文件名。
Public Function OpenWorkBook(wb As Workbook, path As String) As Boolean

On Error GoTo Err

    OpenWorkBook = True

    Dim isWbOpened As Boolean
    isWbOpened = False
    
    Dim fileName As String
    fileName = GetFileName(path)

    'check file is opened or either
    Dim wbTemp As Workbook
    For Each wbTemp In Workbooks
        If wbTemp.Name = fileName Then isWbOpened = True
    
    Next
    
    'open file
    If isWbOpened = False Then
        Workbooks.Open path

    End If
        
    Set wb = Workbooks(fileName)
    
    Exit Function
    
Err:
    OpenWorkBook = False
                   
End Function

 

• 打開一個文件，並將文件賦予到wb中，將文件的sheet頁賦予到ws中的完整代碼。（用到了上面的函數）

'If OpenWorkBook(wb, path & "\" & "filename") = False Then
    MsgBox "open file error."
    GoTo Err
End If
wb.Activate
Set ws = wb.Worksheets("sheetname") 

 

• 打開一個不知道確切名字的文件（文件名中含有serachname），並將文件賦予到wb中，將文件的sheet頁賦予到ws中的完整代碼。

'用到了上上面的函數OpenWorkBook
'If OpenCompanyFile(wb, path, "searchname") = False Then
    MsgBox "open file error."
    GoTo Err
End If
wb.Activate
Set ws = wb.Worksheets("sheetname") 

'直接使用的函數OpenCompanyFile
Function OpenCompanyFile(wbCom As Workbook, strPath As String, strFileName As String) As Boolean

    Dim fs As Variant

    fs = Dir(strPath & "\*.xls") 'seach files
    
    OpenCompanyFile = False
    
    Do While fs <> ""
     
        If InStr(1, fs, strFileName) > 0 Then   'file name match
         
            If OpenWorkBook(wbCom, strPath & "\" & fs) = False Then  'open file

                OpenCompanyFile = False
                Exit Do
                
            Else
            
                OpenCompanyFile = True
                Exit Do
                
            End If

        End If
         
        fs = Dir
     
    Loop

End Function

 

• 數字轉字母（如1轉成A，2轉成B）和字母轉數字

Chr(i + 64)
比如i=1的時候，Chr(i + 64)=A
Asc(i - 64)
比如i=A的時候，Asc(i - 64)=1

 

• 復選框總開關實現。假如有10個子checkbox1~checkbox10，還有一個總開關checkbox11，讓checkbox11控制1~10的選擇和非選擇。

Private Sub CheckBox11_Click()
Dim chb As Variant
If Me.CheckBox11.Value = True Then
    For Each chb In ActiveSheet.OLEObjects
         If chb.Name Like "CheckBox*" And chb.Name <> "CheckBox11" Then
            chb.Object.Value = True
         End If
    Next
Else
    For Each chb In ActiveSheet.OLEObjects
    
         If chb.Name Like "CheckBox*" And chb.Name <> "CheckBox11" Then
            chb.Object.Value = False
         End If
    Next
End If
End Sub

 

• 修改B6單元格所在的pivot的數據源，並刷新pivot

Set pvt = ActiveSheet.Range("B6").PivotTable
pvt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"SheetName!R4C2:R" & lngLastRow & "C22", Version:=xlPivotTableVersion10)
pvt.PivotCache.Refresh

 

• 將一個圖形（比如一個長方形的框"Rectangle 2"）移動到與某個單元格對齊。

ws.Activate
Application.ScreenUpdating = True
ws.Shapes.Range(Array("Rectangle 2")).Select
ws.Shapes.Range(Array("Rectangle 2")).Top = ws.Range("T5").Top
ws.Shapes.Range(Array("Rectangle 2")).Left = ws.Range("T5").Left
Application.ScreenUpdating = False

 

• 遍歷控件。比如遍歷所有的checkbox是否被打挑。

If Me.OLEObjects("CheckBox" & i).Object.Value = True Then
            flgChecked = True
end if

 

• 得到今天的日期

 

dateNow = WorksheetFunction.Text(Now(), "YYYY/MM/DD")

 

• 在某個sheet頁中查找某個關鍵字

 

'****************************************************
'Search keyword from a worksheet(not workbook!)
'****************************************************
Public Function SearchKeyWord(ws As Worksheet, keyword As String) As Boolean
    Dim var1 As Variant
    Set var1 = ws.Cells.Find(What:=keyword, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, MatchByte:=False, SearchFormat:=False)
    If var1 Is Nothing Then
        SearchKeyWord = False
    Else
        SearchKeyWord = True
    End If
End Function

 

• 單元格為空，取不到值的時候，轉化為空字符串。Empty to ""

 

'****************************************************
'Empty to ""
'****************************************************
Public Function ChangeEmptyToString(var As Variant) As String
On Error GoTo Err
    ChangeEmptyToString = CStr(var)
    Exit Function
Err:
    ChangeEmptyToString = ""
End Function

 

• 單元格為空，取不到值的時候，轉化為0。Empty to 0

 

'****************************************************
'Empty to 0
'****************************************************
Public Function ChangeEmptyToLong(var As Variant) As Long
On Error GoTo Err
    ChangeEmptyToLong = CLng(var)
    Exit Function
Err:
    ChangeEmptyToLong = 0
End Function

 

• 找到某個sheet頁中使用的最末行

 

Me.UsedRange.Rows.Count

 

• 遍歷文件夾下的所有文件（自定義文件夾和后綴名），並返回文件列表字典

Function SetFilesToDic(ByVal path As String, ByVal extension As String) As Dictionary

    Dim MyFile As String
    Dim s As String
    Dim count As Integer
    Dim dic As New Dictionary
    
    If Right(path, 1) <> "\" Then
    
        path = path & "\"
    
    End If

    MyFile = Dir(path & "*." & extension)
    
    count = 1
    
    Do While MyFile <> ""

'        If MyFile = "" Then
'            Exit Do
'        End If

        dic.Add count, MyFile
        
        count = count + 1
        MyFile = Dir
        
    Loop
    
    Set SetFilesToDic = dic
    
'    Debug.Print s
End Function

• 生成log

 

Sub txtPrint(ByVal txt$, Optional myPath$ = "") '第2參數可以指定保存txt文件路徑

    If myPath = "" Then myPath = ActiveWorkbook.path & "\log.txt"
    
    Open myPath For Append As #1
    
    Print #1, txt
    
    Close #1
 
End Sub

 

•   [Non-Breaking Space]網頁空格在VBA中的處理

 

替換字符
ChrB(160) & ChrB(0)

上述最終解決方法來自於http://www.blueshop.com.tw/board/FUM20060608180224R4M/BRD2009031011234606U/2.html
 Sdany用戶是通過如下思路找到解決方法的（用MidB和AscB）：

Dim I As Integer 
For I = 1 To LenB(Cells(1, 1))  
    Debug.Print AscB(MidB(Cells(1, 1), I, 1))  
Next 

 

• 延時

 

這段代碼在Excel VBA 和VB里都可以用

'***********VB 延時函數定義*************************************
'聲明
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'延時
Public Sub Delay(ByVal num As Integer)
Dim t As Long
t = timeGetTime
Do Until timeGetTime - t >= num * 1000
DoEvents
Loop
End Sub
'***************************************************************

使用方法:
delay 3'3表示秒數 

 

• 殺掉某程序執行的所有進程

 

Sub KillWord()

    Dim Process

    For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='WINWORD.EXE'")
        Process.Terminate (0)
    Next

End Sub

 

• 監視某單元格的變化

 這里最需要注意的問題就是，如果在這個事件里對單元格進行改變，會繼續出發此事件變成死循環。

所以要在對單元格進行變化之前加上Application.EnableEvents = False，變完之后再改為True。

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err
    Application.EnableEvents = False
    Dim c
    Set dicKtoW = SetDic(ThisWorkbook.Sheets("reference"), 3, 1, 2)
    Set dicKtoX = SetDic(ThisWorkbook.Sheets("reference"), 3, 1, 3)
    For Each c In Target
        If c.Column = 11 Then
            'MsgBox c.Value
            Me.Range("W" & c.Row).Value = GetDic(dicKtoW, c.Value)
            Me.Range("X" & c.Row).Value = GetDic(dicKtoX, c.Value)
        End If
    Next
    Set dicKtoW = Nothing
    Set dicKtoX = Nothing
    Application.EnableEvents = True
Exit Sub
Err:
    MsgBox ("Error!Please contact macro developer.")
    Application.EnableEvents = True
End Sub

 

• On Error的用法

 

1.一般用法
On Error GoTo Label
   各種代碼
   exit sub
Label:
   msgbox Err.Description
   其他錯誤處理

2.對於某段代碼單獨處理
On Error Resume Next
需要監視的代碼
If Err.Number <> 0 Then
    MsgBox Err.Description
End If
On Error GoTo 0

3.上述兩種的結合
On Error Resume Next
需要監視的代碼
If Err.Number <> 0 Then
    MsgBox Err.Description
    Goto Label
End If
On Error GoTo 0
exit sub
Label:
   其他錯誤處理

 

• EXCEL的分組功能和展開收縮功能

'將A列到C列進行分組
Range("A:C").Columns.Group

'默認情況下，分組后的A到C列會是展開狀態，如果想讓A到C列收縮
Range("A:C").EntireColumn.Hidden=True