活動工作表最后一行
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