VBA 代码示例
活动工作表最后一行
m = range("a65536").end(xlup).row '一般情况
m = range("a" & rows.count).end(xlup).row '不做下限时
屏幕闪烁
Application.ScreenUpdating = False '关闭
Application.ScreenUpdating = True '打开
指定文件夹遍历所有工作簿的所有工作表
Dim mypath$, myfile$, ak As Workbook '定义变量
m = Sheet1.Range("a65536").End(xlUp).Row '删除历史记录'
If m > 2 Then
Sheet1.Rows("2:" & m).Clear
m = 1
End If
mypath = ThisWorkbook.Path & "\123\" '确定文件路径'
myfile = Dir(mypath & "*.xls") '确定指定路径'
Do While myfile <> "" '遍历文件夹'
If myfile <> ThisWorkbook.Name Then
Set ak = Workbooks.Open(mypath & myfile) '按照顺序打开文件'
Else
GoTo tiaozhuan '遍历结束跳转至末尾'
End If
For i = 1 To ActiveWorkbook.Worksheets.Count '遍历打开的工作簿中所有工作表'
With ak.Worksheets(i) '对单一表的操作'
nm = ak.Name
nm2 = .Name
n = .Range("a65536").End(xlUp).Row
pp = .Range("a2:s" & n)
n = n - 1
Sheet1.Range("a" & m + 1 & ":s" & m + n) = pp
Sheet1.Range("t" & m + 1 & ":t" & m + n) = nm & nm2
m = m + n
End With
Next i
ak.Close '关闭工作簿'
myfile = Dir '选择下一个工作簿'
Loop
tiaozhuan: '结束Do循环标签'
工作表隐藏
Sheet5.Visible = xlSheetVeryHidden '深度隐藏'
Sheet5.Visible = True '取消隐藏'
Sheet5.Visible = false '普通隐藏'
指定工作表打开(导入/导出)
temp = ThisWorkbook.Path & "\示例.xlsx" '确定文件路径'
Set a = GetObject(temp) '定义文件'
With a.Sheets("sheet1") '指定sheet进行操作'
m = .Range("n65536").End(xlUp).Row
b = .Range("a1:q" & m)
Sheet2.Range("a1:q" & m) = b
a.Close False '关闭工作簿'
End With
Set a = Nothing '初始化变量'
透视表刷新
Sheet1.PivotTables("数据透视表1").PivotCache.Refresh
审阅密码添加解除
Sheets("出库数据").Protect ("123456") '加密'
Sheets("出库数据").Unprotect ("123456") '解密'
添加批注
Sheet1.Cells(a, 15).AddComment Text:=Sheet6.Cells(b, 7)
定点执行
Application.OnTime TimeValue("04:00:00"), "MySub"
outlook邮件一键发送
'新建邮件项目
Set OLApp = CreateObject("Outlook.application")
Set OLMail = OLApp.CreateItem(0)
OLApp.Session.Logon
'发送邮件
na = ThisWorkbook.Name
pa = ThisWorkbook.Path
With OLMail
.To = "qqqqqqqqqqqq@qq.com;asasasas@qq.com" '收件人
.CC = "" '抄送人
.BCC = "" '密送人
.Subject = na '邮件标题
.Body = "邮件仅为测试" '邮件正文
.Attachments.Add (pa & "\" & na) '附件
.send '直接发送 display
End With
操作文件
temp = ThisWorkbook.Path & "\COA\export\"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(temp)
For Each fd In f.subfolders
ls = Dir(fd.Path & "\*.pdf")
Do While ls <> ""
Kill fd.Path & "\" & ls '删除文件
ls = Dir
Loop
RmDir fd.Path '删除空文件夹
Next
Set f = Nothing
Set fs = Nothing
no = Format(Now(), "yyyy-mm-dd")
Sheet5.PivotTables("数据透视表2").PivotCache.Refresh
m = Sheet5.Range("j65536").End(xlUp).Row - 2
For a = 2 To m
MkDir temp & no & " " & Sheet5.Cells(a, 10) '创建文件
Next a
m = Sheet1.Range("b65536").End(xlUp).Row
js = 0
For a = 8 To m
If Sheet1.Cells(a, 12) <> "无" Then
Path = Sheet6.Cells(Sheet1.Cells(a, 12), 5)
pname = Sheet1.Cells(a, 7)
pday = Format(Sheet1.Cells(a, 8), "yyyymmdd")
nname = Sheet1.Cells(a, 4)
nname2 = Sheet6.Cells(Sheet1.Cells(a, 12), 2)
Path2 = temp & no & " " & nname & "\" & nname2
FileCopy Path, Path2 '复制粘贴文件
js = js + 1
On Error Resume Next
Name Path2 As temp & no & " " & nname & "\" & pday & " " & pname & " .pdf" '重命名文件
End If
Next a
Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
m = Sheet1.Range("b65536").End(xlUp).Row
c = 0
For a = 8 To m
If Sheet1.Cells(a, 12) <> "无" Then
coord = Sheet1.Cells(a, 12)
Path = Sheet6.Cells(coord, 5)
Call ShellExecute(Application.hwnd, "print", Path, vbNullString, vbNullString, 3) '打印文件
c = c + 1
Application.Wait Now + TimeValue("0:00:05")
End If
Next a
对单元格判断是否有某字符串，并重复部分字体变红
Public Sub 变红()
Application.ScreenUpdating = False
Sheet2.Range("a1:az65536").Delete
m = Sheet1.Range("a65536").End(xlUp).Row
For a = 2 To m
If Sheet1.Cells(a, 2) & Sheet1.Cells(a, 3) & Sheet1.Cells(a, 4) & Sheet1.Cells(a, 5) & Sheet1.Cells(a, 6) = "" Then
GoTo T1
End If
p = Sheet1.Cells(a, 1)
'分列
Sheets("Sheet1").Select
Range("B" & a & ":F" & a).Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Columns("A:A").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="、", FieldInfo:=Array(Array(1, 2), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
TrailingMinusNumbers:=True
For b = 1 To 6
n = Sheet2.Range("az" & b).End(xlToLeft).Column
For c = 1 To n
If Sheet2.Cells(b, c) <> "" Then
p1 = Application.WorksheetFunction.Text(Sheet2.Cells(b, c), "m/d") ‘p为被查找变量在sheet1.cells(a,1)单元格，p1为查找值
If InStr(p, p1) <> 0 Then
Sheet1.Range("a" & a).Characters(Start:=InStr(p, p1), Length:=Len(p1)).Font.Color = vbRed ’重点
End If
End If
Next c
Next b
T1:
Sheet2.Range("a1:az65536").Clear
Next a
Application.ScreenUpdating = True
End Sub
选择文件窗口
Filename = Application.GetOpenFilename("Excel文件（*.xlsm & *.xlam & *.xlt）,*.xlsm;*.xlam;*.xlt", , "VBA破解")
计算两城市间公里数
Sub test()
Set JS = CreateObject("msscriptcontrol.scriptcontrol")
JS.Language = "JavaScript"
With CreateObject("WinHttp.WinHttpRequest.5.1")
For i = 2 To Sheet1.Range("a65536").End(xlUp).Row
s1 = JS.Eval("encodeURIComponent('" & Sheet1.Cells(i, 1) & "');")
s2 = JS.Eval("encodeURIComponent('" & Sheet1.Cells(i, 3) & "');")
.Open "GET", "http://map.baidu.com/?newmap=1&reqflag=pcmap&biz=1&qt=nav&c=1&sn=2$$$$$$" & s1 & "$$0$$$$&en=2$$$$$$" & s2 & "$$0$$$$", False
.Send
tt = .responsetext
Sheet1.Cells(i, 6) = Val(Split(Split(tt, ":")(2), ",")(0)) / 1000
Next i
End With
End Sub
