活动工作表最后一行
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 & "COAexport"
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
版权声明
1.本站大部分下载资源收集于网络,不保证其完整性以及安全性,请下载后自行测试。
2.本站资源仅供学习和交流使用,版权归资源原作者所有,请在下载后24小时之内自觉删除。
3.若作商业用途,请购买正版,由于未及时购买和付费发生的侵权行为,与本站无关。
4.若内容涉及侵权或违法信息,请联系本站管理员进行下架处理,邮箱ganice520@163.com(本站不支持其他投诉反馈渠道,谢谢合作)
- 上一篇: 轻松合并并计算海量Excel表格、工作表
- 下一篇: MT7621芯片性能,MT7621路由器参数介绍
发表评论