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
网友评论