Excel VBA常用代码总结1

做了几个月的Excel VBA，总结了一些常用的代码，我平时编程的时候参考这些代码，基本可以完成大部分的工作，现在共享出来供大家参考。

说明：本文为大大佐原创，但部分代码也是参考百度得来。

改变背景色

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

ColorIndex一览

vba常用方法

改变文字颜色

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

选中或**某单元格

vba常用方法

'“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单元格。

vba常用方法

获得文档的路径和文件名

ActiveWorkbook.Path　　　　'路徑
ActiveWorkbook.Name　　　'名稱
ActiveWorkbook.FullName　 '路徑＋名稱
'或将ActiveWorkbook换成thisworkbook

隐藏文档

Application.Visible = False

禁止屏幕更新

Application.ScreenUpdating = False

禁止显示提示和警告消息

Application.DisplayAlerts = False

文件夹做成

strPath = "C:\temp\"
MkDir strPath

状态栏文字表示

Application.StatusBar = "计算中"

双击单元格内容变换

vba常用方法

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

vba常用方法

文件夹选择框方法1

vba常用方法

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

vba常用方法

文件夹选择框方法2（推荐）

vba常用方法

 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

vba常用方法

文件选择框方法

vba常用方法

  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

vba常用方法

某列到关键字为止循环方法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是否存在

vba常用方法

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

vba常用方法

向单元格中写入公式

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

vba常用方法

'使用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是否存在

vba常用方法

将EXCEL表格中的两列表格插入到一个Dictionary中

vba常用方法

'函数：在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

vba常用方法

判断文件夹或文件是否存在

vba常用方法

'文件夹
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

vba常用方法

一次注释多行

视图---工具栏---编辑调出编辑工具栏，工具栏上有个“设置注释块” 和 “解除注释快”

打开文件并将文件赋予到第一个参数wb中

vba常用方法

'注意，这里的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

vba常用方法

打开一个文件，并将文件赋予到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中的完整代码。

vba常用方法

'用到了上上面的函数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

vba常用方法

数字转字母（如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的选择和非选择。

vba常用方法

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

vba常用方法

修改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页中查找某个关键字

vba常用方法

'****************************************************
'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

vba常用方法

单元格为空，取不到值的时候，转化为空字符串。Empty to ""

vba常用方法

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

vba常用方法

单元格为空，取不到值的时候，转化为0。Empty to 0

vba常用方法

'****************************************************
'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

vba常用方法

找到某个sheet页中使用的最末行

Me.UsedRange.Rows.Count

遍历文件夹下的所有文件（自定义文件夹和后缀名），并返回文件列表字典

vba常用方法

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

vba常用方法

生成log

vba常用方法

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

vba常用方法

  [Non-Breaking Space]网页空格在VBA中的处理

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

vba常用方法

延时

vba常用方法

这段代码在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表示秒数

vba常用方法

杀掉某程序执行的所有进程

vba常用方法

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

vba常用方法

监视某单元格的变化

这里最需要注意的问题就是，如果在这个事件里对单元格进行改变，会继续出发此事件变成死循环。

所以要在对单元格进行变化之前加上Application.EnableEvents = False，变完之后再改为True。

vba常用方法

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

vba常用方法

On Error的用法

vba常用方法

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:
   其他错误处理

vba常用方法

EXCEL的分组功能和展开收缩功能

'将A列到C列进行分组
Range("A:C").Columns.Group

'默认情况下，分组后的A到C列会是展开状态，如果想让A到C列收缩
Range("A:C").EntireColumn.Hidden=True

vba常用方法

Excel VBA常用代码总结1

相关推荐