常用vba功能汇总

excel文件保存相关

Public Function fastStart(Optional ByVal displayalert = True)
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        '.CalculateBeforeSave = False
        .DisplayAlerts = displayalert
    End With
End Function

Public Function fastEnd()
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Function

''''格式化保存文件的方法需要加上ActiveWindow.ScrollRow = 1把竖直滚动条滚上去
Public Sub perfectSave()
    With ActiveWorkbook
        For i = .Sheets.Count To 1 Step -1
            .Sheets(i).Activate
            .Sheets(i).Range("a1").Select
            ActiveWindow.ScrollRow = 1
            ActiveWindow.Zoom = 100
        Next i
        .Save
    End With
End Sub

格式相关

'''' 对选定区域里的单元格内容依次 调用setOneCamel
Public Sub setCamelCase()
    Set ran = Selection
    With ActiveSheet
    Set cur_ = .Cells(ran.Row, ran.Column)
    colCount = cur_.Offset(0, 1).Column - cur_.Column
    row_Count = ran.Count / colCount
    For i = 1 To row_Count
        .Cells(ran.Row+i-1,ran.Column).Value =setOneCamel(.Cells(ran.Row+i-1,ran.Column).Value)
    Next i
    End With
End Sub

'''' a_bc_de--->aBcDe
Public Function setOneCamelCase(ByVal val)
    arr = Split(val, "_")
    val_ = arr(0)
    For i = 1 To UBound(arr)
        v_ = arr(i)
        val_ = val_ & UCase(Left(v_, 1)) & Right(v_, Len(v_) - 1)
    Next
    setOneCamel = val_
End Function

Public Sub get_height()
    MsgBox Selection.Height
End Sub

''''修改边框用ran.BorderAround xlContinuous, xlThin, 0 使用 
For edge_ = 7 To 10
    With ran.Borders(edge_)
    ××××××
end with
''''会出现设置了边框，但打印预览时不显示边框的bug

''''选定区域，第一行全部合并，第二行起左一空白，右边合并
Public Sub addDepth()
    Application.DisplayAlerts = False
    Set ws = ActiveSheet
    With Selection				''''这一段设置格式的代码可以删除
        .Font.Name = "Meiryo UI"
        .Font.Size = 10
        start_row = .Row
        start_col = .Column
        col_count = UBound(.Value, 2)
        row_Count = UBound(.Value, 1)
        If row_Count <= 1 Or col_count <= 1 Then
            Err.Raise 6666, , "row_Count <= 1 Or col_count <= 1"
        End If
        .UnMerge
    End With

    With ws
        .Range(.Cells(start_row, start_col), .Cells(start_row, start_col + col_count - 1)).Merge
        For i = start_row + 1 To start_row + row_Count - 1
            .Range(.Cells(i, start_col + 1), .Cells(i, start_col + col_count - 1)).Merge
            .Cells(i, start_col + 1).Value = .Cells(i, start_col).Value
        Next i
        Set ran1 = .Range(.Cells(start_row + 1, start_col), .Cells(start_row + row_Count - 1, start_col))
        ran1.Merge
        ran1.Borders.LineStyle = xlContinuous
        ran1.Borders(xlEdgeTop).LineStyle = xlNone
        ran1.ClearContents
    End With
    Application.DisplayAlerts = True
End Sub

剪切板相关

调用setClipboard2时可能出现编译错误：用户定义类型未定义，建议用第一个。

''''编辑剪切板方法1
Public Function setClipboard(ByVal s As String)
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText s
        .PutInClipboard
    End With
End Function

''''编辑剪切板方法2
Sub setClipboard2(ByVal s As String)
  Dim cbData As New DataObject
  cbData.SetText s
  cbData.PutInClipboard
End Sub

''''清空剪切板
Sub copyTextToClipboa()
	Dim MyData As DataObject
	Set MyData = New DataObject
	MyData.SetText ""
	MyData.PutInClipboard
End Sub

''''获取剪切板text，清空后获取到空字符串
Sub CopyTextToClipbola()
	Dim MyData As DataObject
	Dim strClip As String
	Set MyData = New DataObject
	MyData.GetFromClipboard
	strClip = MyData.GetText
	MsgBox strClip
End Sub

Public Function getClipboard()
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        strText = .GetText
        Debug.Print strText
    End With
    getClipboard = strText
End Function

对话框相关

''''用对话框获取文件夹路径 
Public Function getFolderpath()
    Set FolderDialogObject=Application.FileDialog(msoFileDialogFolderPicker) 
    With FolderDialogObject 
        .Title = "select your folder" 
        .InitialFileName = "C:\Users\***\Desktop" 
    End With 
    FolderDialogObject.Show 
    get_folderpath = FolderDialogObject.SelectedItems(1) 
End Function

''''用对话框获取文件路径，未测试 
Sub filePicker() '新建一个对话框对象 
    Set FileDialogObject = Application.FileDialog(msoFileDialogFilePicker) 
    ''''配置对话框 
    With FileDialogObject     
        .Title = "请选择文件"     
        .InitialFileName = "C:\"     
        .AllowMultiSelect = True 
    End With 
    '显示对话框 
    FileDialogObject.Show 
    '获取选择对话框选择的文件 
    Set paths = FileDialogObject.SelectedItems
 End Sub

内容操作相关

''''好像是为选定区域的名字生成默认的带换行和缩进的json对象，比如a1,b2-->{"a1":"a1","b2":"b2"}
Public Sub generateJson()
    Set ws = ActiveSheet
    With Selection
        start_row = .Row
        start_col = .Column
        col_count = UBound(.Value, 2)
        row_Count = UBound(.Value, 1)
    End With
    generate_value_code = MsgBox("generate default value?", vbYesNo)
    s = "{"
    j_prev = start_col
    With ws
        For i = start_row To start_row - 1 + row_Count
            For j = start_col To start_col - 1 + col_count
                If .Cells(i, j) <> "" Then
                    If j = j_prev + 1 Then
                        s = Left(s, Len(s) - 3) & Space(1) & "{"
                    ElseIf j = j_prev - 1 Then
                        s = Left(s, Len(s) - 1) & vbCrLf & Space(4 * (j - start_col + 1)) & "}"
                    End If
                    s = s & vbCrLf & Space(4 * (j - start_col + 1)) & """" & .Cells(i, j) & """:"
                    value_ = """"""
                    If Not LCase(Trim(.Cells(i, j).End(2).Value)) = "string" Then
                        value_ = "null"
                    End If
                    
                    '------------------'ﾉ嵭ﾉ・ﾕJvalue start-------------------------
                    If generate_value_code = 6 Then
                        type_ = LCase(Trim(.Cells(i, j).End(2).Value))
                        Select Case type_
                            Case "integer", "int", "long"
                                value_ = 1
                            Case "float", "double"
                                value_ = 0.1
                            Case "string"
                                ronrimei = .Cells(i, j).End(1).Value
                                prefix_ = "001"
                                If InStr(ronrimei, "ﾈﾕｱｾﾕZ") > 0 Then
                                    value_ = """" & ronrimei & StrConv(prefix_, vbWide) & """"
                                Else
                                    value_ = """" & .Cells(i, j).Value & prefix_ & """"
                                End If
                        End Select
                    End If
                     '------------------'ﾉ嵭ﾉ・ﾕJvalue end-------------------------                                      
                    s = s & value_ & ","
                    j_prev = j
                    GoTo next_j1
                End If               
            Next j
next_j1:
        Next i
    End With
    For j_ = j - start_col To 0 Step -1
        s = s & vbCrLf & Space(4 * j_) & "}"
    Next j_
    
    Call setClipboard(s)
    'With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    '    .SetText s
    '    .PutInClipboard
    'End With
End Sub

遍历文件文件夹相关

public Function walk(ByVal fso, ByVal path1 As String)
	''''dosomething
    'Call countpagesofpath(path1, fso)  
    Set folders1 = fso.getfolder(path1)
    For Each i In folders1.Files
        ''''fso.GetExtensionName(s)获取s的后缀名,s如果是文件夹或者没有后缀名返回空字符串
        ''''dosomething，这里还可以对不同文件名进行不同的操作
		'If (fso.GetExtensionName(s) Like "*xls*") Then
		'	'dosomething
		'End If
    Next i
    For Each i In folders1.subfolders
    	''''dosomething，这里还可以对不同文件名进行不同的操作
        Call walk(fso, i.Path)
    Next i
End Function

Sub testWalk()
	Call fastStart
	Set rs = ThisWorkbook.Sheets("reviewdata")
	rs.Cells.ClearContents
	path1 = "C:\Users\user\Desktop\3\05_service\keiyaku"
	path1 = "C:\Users\user\Desktop\3"
	Set fso = CreateObject("scripting.filesystemobject")
	Call walk(fso, path1)
	Call fastEnd
	Set fso=nothing
End Sub

查找替换字符串相关

''''ran：被操作的区域，searchStr是被搜索的str，然后对searchStr所在的单元格进行替换，
''''把fromStrArray里有全替换成toStrArray的
''''循环调用ran.Find时改变ran，似乎会搜索重新进行。比如能find到a1和a2两个位置，正常情况find a1,a2后退出find，
''''但如果find a1后修改ran的内容，会继续find a2和a1。所以需要记下a1的位置和每次新找到位置进行比较。

Public Function findAndReplaceStrInRan(ByVal ran As Range, ByVal searchStr As String, ByVal fromStrArray, _
ByVal toStrArray, ByVal searchMatchCase As Boolean, ByVal replaceMatchCase As Boolean)
	' vbBinaryCompare :0   vbTextCompare :1
	''''find方法的what可以是模糊查询，*表示0到任意个任意字符，?表示一个任意字符
	
    Set x = ran.Find(searchStr, lookat:=xlPart, MatchCase:=searchMatchCase)
    If Not x Is Nothing Then
        startAddr = x.Address
    End If
    If replaceMatchCase Then
        replaceMatchCaseValue = vbBinaryCompare
    Else
        replaceMatchCaseValue = vbTextCompare
    End If
    
    While Not x Is Nothing
        addr = x.Address
        Set xcell = Range(addr)
        Set x = ran.FindNext(x)
        
        'xcell.Value = Replace(xcell.Value, originStr, newStr)
        For i = LBound(toStrArray) To UBound(toStrArray)
            fromStr = fromStrArray(i)
            If fromStr = "" Then
                GoTo nextwhile
            End If
            toStr = toStrArray(i)
            ''''先to->from是因为：比如目的是把a->ab,已经是ab的地方不变
            
            xcell.Value = Replace(xcell.Value, toStr, fromStr, compare:=replaceMatchCaseValue)
            xcell.Value = Replace(xcell.Value, fromStr, toStr, compare:=replaceMatchCaseValue)
        Next i
nextwhile:
        'If x Is Nothing Or x.Address = startAddr Then          'seperate two ways,else if x is nothing will throw error here
        If x Is Nothing Then
            GoTo out1
        End If
        If x.Address = startAddr Then
            GoTo out1
        End If
    Wend
out1:
End Function

Sub testfindAndReplaceStrInRan()
    Set wb = Workbooks("组织登录.xlsx")
    Set ws = wb.Sheets(3)
    'Set ran = ws.Cells
    Set ran = ws.UsedRange
    Dim fromStrArray(1) As String       'dim a(n)==dim a(0 to n)
    fromStrArray(0) = "as"
    Dim toStrArray(1) As String
    toStrArray(0) = "QW"
    Call findAndReplaceStrInRan(ran, "asd", fromStrArray, toStrArray, False, False)
End Sub

文本文件相关

Function write2TextFile(ByVal content As String, ByVal filepath As String, Optional addMode = True, Optional ByVal fso = Nothing, Optional ByVal charset = "utf-8")
    'filepath = "C:\Users\user\Desktop\1.txt"
    Set ads = CreateObject("adodb.stream")
    
    If fso Is Nothing Then
        fsoExists = True            ''''fsoExists用来关闭fso
        Set fso = CreateObject("scripting.filesystemobject")
    End If
    
    'folderExits = fso.folderexists(filepath)   ''''文件夹是否存在
    fileExits = fso.fileexists(filepath)        ''''文件是否存在
    If fileExits And Not addMode Then
        fso.DeleteFile filepath
        fileExits = False
    End If
    If Not fileExits Then
        'fso.createfolder (filepath)     'create folder     ''''创建文件夹
        Set note = fso.CreateTextFile(Filename:=filepath, overwrite:=True)      ''''创建文本文件
        note.Close      ''''这里不close下面.LoadFromFile filepath会报错
        Set note = Nothing
    End If

   With ads
        .charset = charset
        .Open
        .LoadFromFile filepath
        If addMode Then
            strbuf = .readtext
            .writetext vbCrLf
        End If
        
        .writetext content
        
        .savetofile filepath, 2
        .flush
        .Close
    End With


    Set ads = Nothing
    If fsoExists Then       ''''这个if判断用来关闭fso
        Set fso = Nothing
    End If
End Function

正则表达式相关

Sub testfindAllByReg()
strA = GetWebTxt("https://bbs.hupu.com/34914799-2.html")
Set matchList= findAllByReg(strA, "class=""floor""[\s\S]*?uname=""([\s\S]*?)""[\s\S]*?<table[\s\S]*?td>([\s\S]*?)</td>[\s\S]*?</table")
    For Each mhk In matchList
        'mhk:{firstindex:index from 0,value:match string,length:mhk.value.length}
        For Each sm In mhk.submatches       'for each loop print all submatches
            Debug.Print sm
        Next
    Next
End Sub


Function findAllByReg(ByVal text$, Optional ByVal pattern$, Optional ByVal reg = Empty)
    If reg = Empty Then
        Set reg = CreateObject("vbscript.regexp")
        'reg.pattern = "class=""floor""[\s\S]*?uname=""([\s\S]*?)""[\s\S]*?<table[\s\S]*?td>([\s\S]*?)</td>[\s\S]*?</table"
        reg.pattern = pattern
        reg.Global = True
        reg.IgnoreCase = True               'setting true will Ignore case
        'reg.MultiLine = False              '''更改^和$的含義，分別在任意一行的行首和行尾匹配，而不only在整个字符串的start和end匹配
    End If
    'text = readtxt1("C:\Users\Administrator\Desktop\new3.txt")
    'text = GetWebTxt("https://bbs.hupu.com/34914799-2.html")

    Set findAllByReg = reg.Execute(text)
    'Debug.Print findAllByReg.Count               '2,if can not find,mh.count=0,
    'For Each mhk In findAllByReg
        'mhk:{firstindex:index from 0,value:match string,length:mhk.value.length}
        'For Each sm In mhk.submatches       'for each loop print all submatches
            'Debug.Print sm
        'Next
    'Next
End Function

对话框弹出框

Public Function getPopupPath(Optional ByVal popupType = 4)
    'a1 = msoFileDialogFolderPicker          '4
    'a2 = msoFileDialogFilePicker            '3
    Set popup = Application.FileDialog(popupType)
    With popup
        .Title = "select your folder or file"
        .InitialFileName = "D:"
        '.InitialFileName = "D:/1/A.html"
    End With
    popup.Show
    getFolderpath = popup.SelectedItems(1)
End Function

myfontname = InputBox("insert your font name", Default:="Meiryo UI")

日志相关

Public staticLoglist As New Collection
Public staticLogpath$

Public Function getLoglist(Optional ByVal logpath_ As String)
    If Len(Trim(logpath_)) = 0 And Len(staticLogpath) = 0 Then
        If MsgBox("no logfile path,will use c:/log**.txt", vbYesNo) = vbYes Then
            logpath_ = "c:/vbalog" & Format(Now(), "yyyymmdd_hhmmss") & ".txt"
        Else
            Err.Raise 666, , "please reset your path to save log"
        End If
    End If
    If Len(Trim(logpath_)) > 0 Then
        If Len(staticLogpath) > 0 And staticLogpath <> logpath_ Then operateLoglist (0)
        staticLogpath = logpath_
    End If
    Set getLoglist = staticLoglist
End Function

Public Sub addLog(Optional ByVal kw$, Optional ByVal content$, Optional ByVal addDate As Boolean = True, _
Optional ByVal isErrorlog As Boolean = False, Optional ByVal logpath_$, Optional ByVal dataCount& = 100)
    Call getLoglist(logpath_)
    Dim newlogarr$(1 To 4)
    'newlogarr(1) = kw						'kw not used now
    newlogarr(2) = content
    If addDate Then newlogarr(3) = Now()
    If isErrorlog Then
        newlogarr(4) = "1"
    Else
        newlogarr(4) = "0"
    End If
    
    staticLoglist.Add (newlogarr)
    Call operateLoglist(dataCount)
End Sub

Public Sub operateLoglist(Optional ByVal dataCount As Long = 100, Optional ByVal saveKwOnly As Boolean = False)
    If staticLoglist.Count >= dataCount And dataCount >= 0 Then
        Set fso = CreateObject("scripting.filesystemobject")
        logstr = ""
        For i = 1 To staticLoglist.Count
            'logstr = logstr & staticLoglist(i) & vbCrLf
            logstr = arrlog2str(staticLoglist(i), logstr)
        Next i
        Call write2TextFile(logstr, staticLogpath, , fso)
        'Set staticLoglist = New Collection       'if use static staticLoglist do not use this,has bug
        For i = staticLoglist.Count To 1 Step -1
            staticLoglist.Remove (i)
        Next i
        
        Set fso = Nothing
    End If
End Sub

Public Function arrlog2str(ByVal arr, ByVal logstr$)      'kw,content,data,iserror
    If arr(4) = "1" Then
        logstr = logstr & "[ERROR]"
    Else
        logstr = logstr & "[INFO]"
    End If
    If Len(arr(3)) > 0 Then logstr = logstr & "[" & arr(3) & "]"
    arrlog2str = logstr & arr(2) & vbCrLf
End Function

其他

'sleep
Application.Wait (Now + TimeValue("0:00:01"))				'method1
Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)			'method2
Sleep (1000)

If 1 = 1 Then MsgBox 1
Application.StatusBar = "running"

a1 = Format(Date, "yyyy年m月d日")         
b1 = Format(Time, "hh:mm")             
c1 = Format(Now, "yyyy年mm月dd日hh时mm分ss秒")

ThisWorkbook.Sheets(2).[e3].Formula = "=sum($a$1:d2)"
'r1c2=$a$2,r[-1]c[-2]=[f3].offset(-1,-2)
ThisWorkbook.Sheets(2).[f3].FormulaR1C1 = "=sum(r1c1:r[-1]c[-2])"
Selection.NumberFormatLocal = "G/標準"				'remember to set the style,else will not calculate

Sub uu()			'''is excel file?
	p1 = "C:\Users\Administrator\Desktop\log.txt"
	'p1 = "C:\Users\Administrator\Desktop\1.xlsm"
 	splitarr = Split(p1, ".")
	isExcelFile = splitarr(UBound(splitarr)) Like "*xls*"
	If isExcelFile  Then
		Set a = Workbooks.Open(p1)
	End If
End Sub