全民一起VBA实战篇第一课：表格格式操作与Excel功能调用

文件打印

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

.将所选部分删除，保存文件，再替换到压缩文件里面

再改回去

破解成功