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
复制代码

 

  • &nbsp; [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:
   其他错误处理
复制代码
posted @ 2023-04-15 23:37  快乐58  阅读(750)  评论(0)    收藏  举报