常用短句

活动工作表最后一行

  • 常用情况

    m = range(“a65536”).end(xlup).row

  • 最大下限

    m = range(“a” & rows.count).end(xlup).row

屏幕闪烁

  • 关闭

    Application.ScreenUpdating = False

  • 打开

    Application.ScreenUpdating = True

警告提示

  • 关闭

    Application.DisplayAlerts = False

  • 打开

    Application.DisplayAlerts = True

工作表隐藏

  • 深度隐藏

    Sheet5.Visible = xlSheetVeryHidden

  • 普通隐藏

    Sheet5.Visible = false

  • 取消隐藏

    Sheet5.Visible = True

审阅密码

  • 加密

    Sheets(“sheet1”).Protect (“123456”)

  • 解密

    Sheets(“sheet1”).Unprotect (“123456”)

透视表刷新

Sheet1.PivotTables(“数据透视表1”).PivotCache.Refresh

指定单元格添加批注

Sheet1.Cells(1, 1).AddComment Text:=”批注内容”

定点执行

Application.OnTime TimeValue(“04:00:00”), “MySub”

选择文件窗口

Filename = Application.GetOpenFilename(“Excel文件（*.xlsm & .xlam & .xlt）,.xlsm;.xlam;*.xlt”, , “VBA破解”)

功能性模块

遍历文件夹全部工作簿的全部工作表

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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循环标签'

outlook邮件一键发送

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
'新建邮件项目
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) '附件
    pdy = Msgbox("是否田间邮件正文内容？", vbYesNo) '判断是不是直接发送邮件
    if pdy = vbNo Then
        .send '直接发送 display
    Else
        .display
    endif
End With

通过百度计算两城市间公里数

1
2
3
4
5
6
7
8
9
10
11
12
13
14
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