美文网首页
Excel 宏 VBA-工作常用小功能_随手

Excel 宏 VBA-工作常用小功能_随手

作者: 菠萝_4792 | 来源:发表于2020-02-03 20:51 被阅读0次

VBA小白,随手积累工作中用到的各种代码模块


VBA - Google网站

https://stackoverflow.com/
可以尝试Google英文检索想要的功能,优先推荐的代码相关度/质量都挺好。

VBA 正文

多选下拉菜单

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    
    If Target.Count > 1 Then GoTo exitHandler
    On Error Resume Next
    
    Set rngDV = Range("C2")
    On Error GoTo exitHandler
    
    If rngDV Is Nothing Then GoTo exitHandler

    If Intersect(Target, rngDV) Is Nothing Then
       'do nothing
    Else
      Application.EnableEvents = False ' 让事件失效
            ' 举个例子,比如在bai工作表的change事件中,设置当a1单元格数据改du变时zhi,a2和a3也跟着变当a1改变时,就会触发sheet_change事件dao,然后就会改变a2和a3的值,而如果此时没有设置。
            'application.enableevents=false,由于a2和a3的值也改变了,这时也会触发sheet_change事件,如果不想因为a2和a3的值改变而触发这个事件,就必须在改变a2和a3的值之前先加上这句代码。
            'Application.EnableEvents = False '让事件失效。
            'Application.EnableEvents = True '让事件生效。
      newVal = Target.Value
      Application.Undo
      oldVal = Target.Value
      Target.Value = newVal
      If Target.Column = 3 And Target.Row = 2 Then
        If oldVal = "" Then
          'do nothing
          Else
          If newVal = "" Then
          'do nothing
          Else
          Target.Value = oldVal _
            & ", " & newVal
    '      NOTE: you can use a line break,
    '      instead of a comma
    '      Target.Value = oldVal _
    '        & Chr(10) & newVal
          End If
        End If
      End If
    End If
    
exitHandler: Application.EnableEvents = True
End Sub

公共宏-打开所在文件夹

Sub A_打开当前文件夹()

Shell "explorer.exe " & ActiveWorkbook.Path, vbMaximizedFocus

End Sub

公共宏-保存文档

Sub A_另存当前文件()

Application.ScreenUpdating = False

Dim CK As String, CK2 As String, mypath As String, myfilename As String

    CK = MsgBox("保存到Download?", vbYesNo)
        If CK = 6 Then
            mypath = "\\shavnasgcg0001\bg52134$\Downloads\"
        Else
            mypath = InputBox("文件路径") & "\"
    '        On Error Resume Next
    '        VBA.MkDir (mypath)
        End If
    CK2 = MsgBox("用当前文件名?", vbYesNo)
        If CK2 = 6 Then
            myfilename = ActiveWorkbook.Name
'            MsgBox mypath & myfilename
            ActiveWorkbook.SaveAs Filename:= _
            mypath & myfilename, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Else
            myfilename = InputBox("输入文件名") & ".xlsx"
'            MsgBox mypath & myfilename
            ActiveWorkbook.SaveAs Filename:= _
            mypath & myfilename, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        End If

Application.ScreenUpdating = True

        
End Sub

保存当前sheet()

Sub A_当前sheet保存()
Application.ScreenUpdating = False
ActiveWorkbook.Save

'Dim sht As Worksheet
'sht = ActiveSheet
    ActiveSheet.Copy
     ActiveWorkbook.SaveAs Filename:= _
        "\\shavnasgcg0001\bg52134$\Downloads\" & ActiveSheet.Name & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close


Application.ScreenUpdating = True

End Sub

保存所有sheet

Sub A_所有sheet保存()
Application.ScreenUpdating = False
ActiveWorkbook.Save

Dim sht As Worksheet
For Each sht In Worksheets
    sht.Copy
     ActiveWorkbook.SaveAs Filename:= _
        "\\shavnasgcg0001\bg52134$\Downloads\" & sht.Name & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
Next

Application.ScreenUpdating = True

End Sub

延时函数

  • Wait函数,精确到秒
  • sleep timegettime,都支持精确到毫秒级
如果需要更低精度的延时,需要使用Sleep API函数,如下面的代码所示。
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub MyTypeDemo()
Dim sTest As String
Dim i As Integer
sTest = "欢迎你来到这个平台学习VBA!"
For i = 1 To Len(sTest)
Range("A1").Value = Left(sTest, i)
Sleep 200
Next
End Sub

复制到剪贴板

Dim str$
    Dim obj As Object
    Set obj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    str = "欢迎你的使用" & vbCrLf & vbCrLf & _
          "这只是一个测试实例" & x & vbCrLf & _
          Rest
    MsgBox str, vbOKOnly, "系统提示"
    obj.SetText str
    obj.PutInClipboard
    Set obj = Nothing
Sub CopyToClipbox()
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText "要复制的文字"
        .PutInClipboard
    End With
End Sub

中间的那串字符是什么意思

自动计算宏总共运行的时间

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer

'*****************************
'Insert Your Code Here...
'*****************************

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

自动保存邮件到指定路径

谷歌检索参考网页

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
 
    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
   
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
     
    sPath = enviro & "\Documents\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
  
  End If
  Next
  
End Sub
 
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

自动保存邮件以并复制邮件地址到剪贴板

Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
  Dim obj As Object
 
    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
   
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnn", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
    
    sPath = "\\shavnasgcg0001\bg52134$\Downloads\"
    '邮件保存 - sPath = "I:\1-Irene\Mail backup\1- BAU-CDD\201911\CDD\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
  
  End If
  Next
  
    Set obj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    obj.SetText sPath & sName
    obj.PutInClipboard
    Set obj = Nothing
  
End Sub
 
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

完整引用单元格

Application.Workbooks("Book1").Worksheets("Sheet1").Range ("A1")

Function函数-统计黄色单元格个数

Function countclr(arr As Range)
    Dim rng As Range
    For Each rng In arr
        If rng.Interior.Color = RGB(255, 255, 0) Then
            countclr = countclr + 1
        End If
    Next rng
End Function

Function 自动统计一定范围内多少单元格为指定颜色

  • 在第一行设置第二个参数
Function countclr2(arr As Range, a As Range)
    Dim rng As Range
    For Each rng In arr
        If rng.Interior.Color = a.Interior.Color Then
            countclr2 = countclr2 + 1
        End If
    Next rng
End Function

批量新建工作表

Sub ShtAdd()
    '以"数据"工作表A列中的信息来新建不同名称的工作表
    Dim i As Integer, sht As Worksheet
    i = 2                                  '保存第1个工作表名称的单元格在第2行
    Set sht = activeworksheet           '将保存工作表名称的工作表赋给变量sht
    Do While sht.Cells(i, "A") <> ""           '直到A列的单元格为空时退出循环
        Worksheets.Add after:=Worksheets(Worksheets.Count)     '在所有工作表后插入新工作表
        ActiveSheet.Name = sht.Cells(i, "A").Value                '更改工作表的标签名称
        i = i + 1                           '行号增加1
    Loop
End Sub

命名表头 / 数组

Set sht = Wb.Worksheets(1)
    With sht
        .Name = "花名册"  '修改第一张工作表的标签名称
        '设置表头
        .Range("A1:F1") = Array("序号", "姓名", "性别", "出生年月", "参加工作时间", "备注")
    End With

上级文件夹

p = ThisWorkbook.Path
p = Mid(p, 1, InStrRev(p, "\"))

判断是否数字

isnumeric函数
dim rng as range
for each rng in activesheet.usedrange
    if not isnumeric(rng) then '如果单元格的字符不是数字,则直接标红
        rng.interior.colorindex=3
    else '是数字,则将单元格值修正为数值,当然你也可以修正为文本
        rng.value=val(rng.value)
    endif
next rng

打开文件自动运行宏

Workbooks.Open "ANALYSIS.XLS" 
ActiveWorkbook.RunAutoMacros xlAutoOpen

打开文件后自动输入密码

Workbooks.Open Filename:="\\canvnasgcg0001\\CDD closure manual log.xlsm", Password:="Cbsu111"

显示所有隐藏表单

Sub T_显示所有表格()

Dim sht As Worksheet
For Each sht In ActiveWorkbook.Worksheets
    sht.Visible = 1
Next

End Sub

不连续行/列隐藏

Sub T()
'行
   Range("16:21,24:24,26:26,37:49,66:79").Select
   Selection.EntireRow.Hidden = True
   [A1].Select

'列
Union(Range("A:A"), Range("F:F"), ……).EntireColumn.Hidden = True
Union(Columns(1), Columns(6), ……).EntireColumn.Hidden = True

每张表单单独保存

Sub saveworkbook()
'将sheet工作表批量另存为独立的工作簿,并命名成sheet表的名称
Application.ScreenUpdating = False '关闭屏幕更新
Dim ff As String '定义字符变量
ff = ThisWorkbook.Path & "\五座神山"
'指定建立新的工作簿保存到的路径
If Len(Dir(ff, vbDirectory)) = 0 Then MkDir ff
'如果五座神山的文件架不存在,就新建文件夹;mkdir用来 新建文件夹
Dim st As Worksheet   '定义工作表变量
For Each st In Worksheets  '遍历所有的sheet工作表
   st.Copy     ' 拷贝sheet工作表到新的工作簿,即将工作表另存为新的文件。
   ActiveWorkbook.SaveAs ff & "\" & st.Name & ".xlsx"  '保存工作簿,并命名成工作表的名称
   ActiveWorkbook.Close         '关闭工作表
   Next '执行遍历循环体
Application.ScreenUpdating = True   '开启屏幕更新
End Sub

单工作簿多工作表汇总

Sub Opiona()
    
    
    '禁止系统刷屏?触发其他事件等
    'On Error Resume Next    '// 发生错误,自动执行下一句,就是忽略错误
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Application.EnableEvents = False  '//禁止触发其他事件
    
    Dim T
    T = Timer  '//开始时间
    
    Dim SQLARR
    Dim I, X As Integer
    Dim Str_coon, StrSQL As String
    Dim SH1, SH0, SHW As Worksheet
    
    Set SH1 = Sheets("汇总")
    SH1.Range("A4:HZ1048576").ClearContents
    
    Rem 组合查询标题
    StrBT = ""
    For ICOL = 2 To SH1.Range("HZ3").End(xlToLeft).Column
        StrBT = StrBT & ",[" & SH1.Cells(3, ICOL).Value & "]"
    Next
    
    Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003,2007 通用
    Rem 遍历工作表
    For Each SH In Worksheets
        If SH.Name <> SH1.Name Then
            Rem 查询数据
            StrSQL = "SELECT '" & SH.Name & "' AS 工作表名"
            StrSQL = StrSQL & StrBT
            StrSQL = StrSQL & " FROM [" & SH.Name & "$A" & SH1.Range("B1").Value & ":HZ]"
            SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
            Rem 粘贴到汇总表中
            LASTROW = SH1.Range("A1048576").End(3).Row + 1
            SH1.Range("A" & LASTROW).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
        End If
    Next
    
    Application.EnableEvents = True  '//  '//恢复触发其他事件
    Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
    MsgBox "一共用时:" & Format(Timer - T, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
End Sub


'*****************************************************************************************
'函数名:    GET_SQL_To_Arr
'函数功能:  获得指定SQL的查询结果,自定义连接字符串,可以连接各种数据库
'返回值:    返回一个二维数组
'参数1:     StrSQL   字符类型   SQL查询语句
'参数2:     Str_coon 字符类型   数据库连接语句
'Str_coon = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & ThisWorkbook.FullName      '//OFFICE2003
'Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2007
'Str_coon = "HDR=yes';Data Source =" & FileArr(i)    '//OFFICE2003,2007 通用
'参数3:     Biaoti   可参数选   是否输出标题,默认带有标题
'使用方法:
'            SQLARR= GET_SQL_To_Arr(StrSQL,Str_coon,true)
'            SQLARR(0,1)  '//数组第一行为标题行,从i=1 开始是数据
'            Sh2.Range("A2").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
'整理:北极狐工作室 QQ:14885553
'*****************************************************************************************
Public Function GET_SQL_To_Arr(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()
    'On Error Resume Next    ' 改变错误处理的方式。
    Dim CN, RS
    Dim arr()
    Dim I As Long
    
    Err.Clear
    Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
    Set RS = CreateObject("adodb.recordset")
    Rem Str_coon = "HDR=yes';Data Source=" & ThisWorkbook.FullName
    If InStr(Str_coon, "Provider=") = 0 Then
        If Val(Application.Version * 1) < 12 Then
            Str_coon = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;" & Str_coon
        Else
            Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;" & Str_coon
        End If
    End If
    CN.CursorLocation = 3
    CN.Open Str_coon
    RS.Open StrSQL, CN, 1, 3
    
    Rem 如果不要标题,可以:arr = RS.GetRows,代码比较省,但是速度一般
    
    Rem SET RS=CN.Execute(StrSQL)
    If RS.RecordCount > 0 Then '//如果找到数据
        If Biaoti = True Then
            ReDim arr(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
            For A = 0 To RS.Fields.Count - 1  '//导入标题
                arr(0, A) = RS.Fields(A).Name
            Next
            For I = 0 To RS.RecordCount - 1  '//导入数据
                For A = 0 To RS.Fields.Count - 1
                    arr(I + 1, A) = RS.Fields(A).Value
                Next A
                RS.MoveNext
            Next
        Else
            ReDim arr(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
            For I = 0 To RS.RecordCount - 1  '//导入数据
                For A = 0 To RS.Fields.Count - 1
                    arr(I, A) = RS.Fields(A).Value
                Next A
                RS.MoveNext
            Next
        End If
    Else '//如果没有找到数据
        If Biaoti = True Then
            ReDim arr(0 To 0, 0 To RS.Fields.Count - 1)
            For A = 0 To RS.Fields.Count - 1  '//导入标题
                arr(0, A) = RS.Fields(A).Name
            Next
        Else
            ReDim arr(0, 0)
            arr(0, 0) = ""
        End If
    End If
    
    If Err.Number <> 0 Then
        MsgBox "Error!" & Err.Description
        ReDim arr(0, 0)
        arr(0, 0) = "Error"
        GET_SQL_To_Arr = arr(0, 0)
    End If
    
    GET_SQL_To_Arr = arr
    
    RS.Close
    CN.Close  '//关闭ADO连接
    Set RS = Nothing
    Set CN = Nothing  '//释放内存
End Function
Dim sht As Worksheet
    Set sht = Worksheets("成绩表")
    sht.Rows("2:65536").Clear      '删除成绩表中的原有记录
    Dim wt As Worksheet, xrow As Integer, rng As Range
    For Each wt In Worksheets                   '循环处理工作簿中的每张工作表
        If wt.Name <> "成绩表" Then
            Set rng = sht.Range("A1048576").End(xlUp).Offset(1, 0)
            xrow = wt.Range("A1").CurrentRegion.Rows.Count - 1
            wt.Range("A2").Resize(xrow, 7).Copy rng
        End If
    Next
End Sub

相关文章

  • Excel 宏 VBA-工作常用小功能_随手

    VBA小白,随手积累工作中用到的各种代码模块 VBA - Google网站 https://stackoverfl...

  • 【Office技巧】宏

    VBA-宏基本用法 今天就来港下office里最藏在深闺人未识的功能——宏。 一般听说过“宏”的电脑小白们,对“宏...

  • excel-vlookup多条件查询

    不常用excel公式,宏这块内容,用到了Excel公式进行计算,还是写个小总结,记录我不常用但比较好用的公式~~~...

  • Excel 自定义函数记录

    Excel编写自定义函数 Excel是我们日常工作中常用的工具,其提供了许多常用宏,能够满足我们的大部分工作需求,...

  • 218-试用期第34天

    这是李婷365日写作计划第34天的写作内容 9.3号工作日清: 1.学习EXCEL的宏功能 昨天了解了宏功能的基本...

  • 2、效率加倍的快捷键

    Excel宏如何进行录制与调用 录制宏 1、对于从没使用过Excel宏功能的话,一般要先进行添加“宏”选项,具体路...

  • 小白也要懂的办公软件8:人人都要会的Excel使用技巧!

    导语:不以工作为导向的学习都是浪费时间,这里只有最实用的Excel常用功能集锦! Microsoft Excel是...

  • 在Excel里,查找与替换是工作中最常用的功能之一。就是因为太常用而又简单,大多数都忽视掉这项功能真正强大的之处。...

  • 如何用Excel制作二维码

    Excel除了常见的数据运算分析功能,还有些不太常用的冷门功能。今天来看下二维码如何用Excel生成(Excel2...

  • 一、VBA简介——个人宏工作簿保存方法

    当在一个Excel表格中录制宏,保存方式为”个人宏工作簿“时,宏录制结束,直接保存Excel表格时,将会出现如下警...

网友评论

      本文标题:Excel 宏 VBA-工作常用小功能_随手

      本文链接:https://www.haomeiwen.com/subject/zstcxhtx.html