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