文件打印
Sub 批量打印()
Dim fn As String, wb As Workbook, ws As Worksheet
fn = Dir("E:\EXCEL\*.xlsx")
Do While fn <> ""
Set wb = Workbooks.Open("E:\EXCEL\" & fn)
'打开每个excel文件
For Each ws In wb.Worksheets
'扫描每一个文件里的工作簿
ws.PrintOut
'打印
Next ws
wb.Close
fn = Dir
Loop
End Sub
重复打印几份文件
ws.PrintOut copies:=3
当然,写一个for循环也可以多打印,不过效率低一点
但是写for可以更灵活的操作文档,视情况而定
设置打印细节
MSDN给了属性的文档
https://docs.microsoft.com/zh-cn/office/vba/api/Excel.PageSetup.Orientation
Sub 批量打印()
Dim fn As String, wb As Workbook, ws As Worksheet
fn = Dir("E:\EXCEL\*.xlsx")
Do While fn <> ""
Set wb = Workbooks.Open("E:\EXCEL\" & fn)
For Each ws In wb.Worksheets
With ws.PageSetup
'设置属性
.PaperSize = xlPaperA4
'纸型为A4
.Orientation = xlLandscape
'方向为横向
'portrait为纵向
.Zoom = 110
End With
ws.PrintOut
Next ws
wb.Close
fn = Dir
Loop
End Sub
定时器
可以通过定时器的设置来定时操作
每隔固定时间自动染色
Option Explicit
Dim timepoint As Date
'定义全局变量,方便读取时间
Sub color()
Dim r As Long, c As Long
r = 1 + Int(Rnd() * 10)
c = 1 + Int(Rnd() * 10)
'给随机数
Cells(r, c).Interior.color = vbRed
timepoint = Now + 1 / 24 / 6000
'时间定为现在时间的下一0.6秒
Application.OnTime timepoint, procedure:="color"
'执行时间,执行程序
End Sub
Sub stoptimer()
Application.OnTime timepoint, procedure:="color", schedule:=False
'从全局变量中得到时间,除了最后schedule多一个,其他都要一模一样
'用来禁止程序
End Sub
隐藏工作簿
Sub 隐藏()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Sheet1" Then
' ws.Visible = xlSheetVisible
ws.Visible = xlSheetVeryHidden
'强力隐藏,用户在EXCEL界面上解不开
End If
Next ws
End Sub
这种方式隐藏后,直接在EXCXL是看不出来,也解不开的
只有写代码来解开,或者在VBE里面修改属性
跨range区域求和
题目源自2012年的国赛数模题,评价葡萄酒指标
要求对不同葡萄酒的总分进行汇总计算
需要定位到每个非空的range,然后把他们的和求出来,再复制到新表
Option Explicit
Sub 不同range区域的求和()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim r As Range, r1 As Range, sum As Long
Dim i As Long, count
Set ws3 = Worksheets("第一组红葡萄酒品尝评分")
Set ws1 = Worksheets("第二组红葡萄酒品尝评分")
count = 0
For Each ws2 In Worksheets
If ws2.Name = "汇总结果" Then
count = count + 1
End If
Next ws2
If count = 0 Then
Worksheets.Add.Name = "汇总结果"
End If
Set ws2 = Worksheets("汇总结果")
i = 2
For Each r In ws1.Cells.SpecialCells(xlCellTypeConstants).Areas
'扫描每一个非空range
If r.Columns.count > 3 Then
'判断,保证统计到的都是样品分数,避免其他区域造成影响
r.Cells(1, 1).UnMerge
'为了得到样品名称,取消合并单元格,读取其值
sum = Application.WorksheetFunction.sum _
(Range(r.Cells(3, 3), r.Cells(12, 12)))
'对分数区域进行求和
ws2.Cells(i, 6) = sum
ws2.Cells(i, 5) = r.Cells(1, 1).Value
'把分数和名称复制到新表
Range(r.Cells(1, 1), r.Cells(2, 2)).Merge
'合并回去
i = i + 1
End If
Next r
i = 2
For Each r In ws3.Cells.SpecialCells(xlCellTypeConstants).Areas
'扫描每一个非空range
If r.Columns.count > 3 Then
'判断,保证统计到的都是样品分数,避免其他区域造成影响
r.Cells(1, 1).UnMerge
'为了得到样品名称,取消合并单元格,读取其值
sum = Application.WorksheetFunction.sum _
(Range(r.Cells(3, 3), r.Cells(12, 12)))
'对分数区域进行求和
ws2.Cells(i, 3) = sum
ws2.Cells(i, 2) = r.Cells(1, 1).Value
'把分数和名称复制到新表
Range(r.Cells(1, 1), r.Cells(2, 2)).Merge
'合并回去
i = i + 1
End If
Next r
ws2.Cells(1, 2) = "样品名称": ws2.Cells(1, 5) = "样品名称"
ws2.Cells(1, 3) = "得分情况": ws2.Cells(1, 6) = "得分情况"
End Sub
数据来源
http://www.mcm.edu.cn/problem/2012/2012.html
操作窗体等Shape对象
操作窗体控件
Sub 调节窗体位置()
Dim s As Shape, w1 As Worksheet
Set w1 = Worksheets("Sheet1")
Set s = w1.Shapes("按钮 4")
With s
.Top = 20 '距离顶边距离
.Left = 12 '距离左边距离
.Width = 50 '调节窗体宽度
.Height = 400 '调节窗体高度
End With
End Sub
窗体的名字可以右键窗体,然后读取
也可以触发selectionchange事件,让操作更为灵活,动态调整窗体位置
在对应sheet1里面写
Private Sub worksheet_selectionchange(ByVal target As Range)
Dim s As Shape, w As Worksheet
Set w = Worksheets("Sheet1")
Set s = w.Shapes("Button 4")
s.Top = target.Top
s.Left = target.Left + target.Width
End Sub
如果想让窗体每次都显示在所能见到的页面的左上端,可以这样来写
Private Sub worksheet_selectionchange(ByVal target As Range)
Dim s As Shape, w As Worksheet
Set w = Worksheets("Sheet1")
Set s = w.Shapes("Button 4")
's.Top = Application.ActiveWindow.VisibleRange.Top
'显示在当前页面的左上角
s.Top = Application.ActiveWindow.VisibleRange.Top _
+ Application.ActiveWindow.VisibleRange.Height _
- s.Height
'显示在当前页面的左下角
End Sub
操作图表
Sub 调节图表位置()
Dim s As Shape, w1 As Worksheet
Set w1 = Worksheets("Sheet1")
Set s = w1.Shapes("图表 1")
With s
.Top = 1
.Left = 120
.Width = 500
.Height = 400
End With
End Sub
操作shape
Sub 控制shape()
Dim s As Shape
For Each s In Application.ActiveSheet.Shapes
'遍历当前工作簿的shape集合
If s.Type = msoChart Then
'如果s的类型是chart
s.Visible = Not s.Visible
End If
Next s
End Sub
破解工作表加密
针对工作表的保护,可以绕过加密机制
将文件后缀名改为.zip或者.rar
找到
拖出sheet1,然后用记事本打开,找到protection
.将所选部分删除,保存文件,再替换到压缩文件里面
再改回去
破解成功