首页 编程设计VBA编程正文

VBA 代码示例

云水 VBA编程 2019-12-16 15:48:52 1279 0 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 & "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(本站不支持其他投诉反馈渠道,谢谢合作)

本文链接:http://apod.cc/index.php/post/211.html

发表评论

评论列表(0人评论 , 1279人围观)
☹还没有评论,来说两句吧...