Excel-常用宏技巧（4）

自动隐藏表格中无数据的行

表1 是数据源，经常改变；

表2 引用表1 中某列有数据的单元格（利用动态位址已实现。）

由于表1 的改变，表2 的大小随之而变。

问题：如何实现表2 中没有数据的行（有公式）自动隐藏？谢谢赐教！

Sub abc()

For i = 1 To 300

If Cells(i, 1).value = "" Then Rows(i).Hidden = True

Next i

End Sub

你写的语句可以解决隐藏的问题，可是如果我执行了它之后，再在表1中增加数据，表2不会自动显示有了数据的行。如何修改？

将此宏设为自动运行（打开文件时）

Sub abc()

For i = 1 To 300

If Cells(i, 1).value <>"" Then Rows(i).Hidden = false

Next i

End Sub

用VBA如何自动合并列的内容？

用VBA如何自动合并列的内容？

To hongjian ：

Sub MergeTest()

For i = 3 To 30

Cells(i, 3) = Cells(i, 1) & Chr(10) & Cells(i, 2)

Next

End Sub

基于VB和EXCEL的报表设计及打印

　　在现代管理信息系统的开发中，经常涉及到数据信息的分析、加工，

最终还需把统计结果形成各种形式的报表提供给领导决策参考，或进行外

部交流。在Visual Basic中制作报表，通常是用数据环境设计器(Data

Environment Designer)与数据报表设计器(Data Report Designer),或者

使用第三方产品来完成。但对于大多数习惯于Excel报表的用户而言,用以

上方法生成的报表在格式和功能等方面往往不能满足他们的要求。

　　由于Excel具有自己的对象库，在Visual Basic工程中可以加以引用，

通过对Excel使用OLE自动化，可以创建一些外观整洁的报表，然后打印输

出。这样实现了Visual Basi应用程序对Excel的控制。本文将针对一个具

体实例，阐述基于VB和EXCEL的报表设计及打印过程。

　1）创建Excel对象

　　Excel对象模型包括了128个不同的对象，从矩形、文本框等简单的对

象到透视表，图表等复杂的对象。下面简单介绍一下其中最重要，也是用

得最多的五个对象。

（1）Application对象

　　Application对象处于Excel对象层次结构的顶层，表示 Excel自身的

运行环境。

（2）Workbook对象

　　Workbook对象直接地处于Application对象的下层，表示一个Excel工

作薄文件。

（3）Worksheet对象

　　Worksheet对象包含于Workbook对象，表示一个Excel工作表。

（4）Range对象

　　Range对象包含于Worksheet对象，表示 Excel工作表中的一个或多个

单元格。

（5）Cells对象

　　Cells对象包含于Worksheet对象，表示Excel工作表中的一个单元格。

　　如果要启动一个Excel，使用Workbook和Worksheet对象，下面的代码

启动了Excel并创建了一个新的包含一个工作表的工作薄：

Dim zsbexcel As Excel.Application

Set zsbexcel = New Excel.Application

　　　　zsbexcel.Visible = True

如要Excel不可见，可使zsbexcel.Visible = False

　　zsbexcel.SheetsInNewWorkbook = 1

　　Set zsbworkbook = zsbexcel.Workbooks.Add

　2）设置单元格和区域值

　　要设置一张工作表中每个单元格的值，可以使用Worksheet对象的

Range属性或Cells属性。

With zsbexcel.ActiveSheet

　　　　.Cells(1, 2).value = "100"

　　　　.Cells(2, 2).value = "200"

　　　　.Cells(3, 2).value = "=SUM(B1:B2)"

　　　　.Range("A3:A9") = "中国人民解放军"

　　End With

　　要设置单元格或区域的字体、边框，可以利用Range对象或Cells对象

的Borders属性和Font属性：

　　With objexcel.ActiveSheet.Range("A2:K9").Borders　 '边框设置

　　　　.LineStyle = xlBorderLineStyleContinuous

　　　　.Weight = xlThin

　　　　.ColorIndex = 1

　　End With

　　With objexcel.ActiveSheet.Range("A3:K9").Font　　'字体设置

　　　　.Size = 14

　　　　.Bold = True

　　　　.Italic = True

　　　　.ColorIndex = 3

　　End With

　　通过对Excel单元格和区域值的各种设置的深入了解,可以创建各种复

杂、美观、满足需要的、具有自己特点的报表。

　3）预览及打印

　　生成所需要的工作表后，就可以对EXCEL发出预览、打印指令了。

　　zsbexcel.ActiveSheet.PageSetup.Orientation = xlPortrait　　 '

　　设置打印方向

　　zsbexcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4　　　'

　　设置打印纸的打下

　　zsbexcel.Caption = "打印预览"　　　　　　　 '设置预览窗口的

　　标题

　　zsbexcel.ActiveSheet.PrintPreview　　　　　　'打印预览

　　zsbexcel.ActiveSheet.PrintOut　　　　　　　　'打印输出

　　通过打印方向、打印纸张大小的设置，不断进行预览，直到满意为止，

最终进行打印输出。

　　为了在退出应用程序后EXCEL不提示用户是否保存已修改的文件,需使

用如下语句：

　　zsbexcel.DisplayAlerts = False

　　zsbexcel.Quit　　　 '退出EXCEL

　　zsbexcel.DisplayAlerts = True

　　如此设计的报表打印是通过 EXCEL程序来后台实现的。对于使用者来

说，根本看不到具体过程，只看到一张张漂亮的报表轻易地被打印出来了。

　4）具体实例

　　下面给出一个具体实例，它在window98、Visual Basic 6.0、

Microsoft Office97的环境下调试通过。

　　在VB中启动一个新的Standard EXE工程，在“工程”菜单的“引用”

选项下引用Excel Object Library；然后在Form中添加一个命令按钮

cmdExcel；最后在窗体中输入如下代码：

　　Dim zsbexcel As Excel.Application

　　　　　　Private Sub cmdExcel_Click()

　　　　　　　　　　Set zsbexcel = New Excel.Application

　　　zsbexcel.Visible = True

　　　zsbexcel.SheetsInNewWorkbook = 1

　　　Set zsbworkbook = zsbexcel.Workbooks.Add

　　　With zsbexcel.ActiveSheet.Range("A2:C9").Borders　　　'边框设置

　　　　　　.LineStyle = xlBorderLineStyleContinuous

　　　　　　.Weight = xlThin

　　　　　　.ColorIndex = 1

　　　　　　End With

　　　With zsbexcel.ActiveSheet.Range("A3:C9").Font　　'字体设置

　　　　　　 .Size = 14

　　　　　　.Bold = True

　　　　　　.Italic = True

　　　　　　.ColorIndex = 3

　　　End With

　　zsbexcel.ActiveSheet.Rows.HorizontalAlignment =

xlVAlignCenter　　　'水平居中

　　zsbexcel.ActiveSheet.Rows.VerticalAlignment =

xlVAlignCenter　　　　'垂直居中

　　With zsbexcel.ActiveSheet

　　　　.Cells(1, 2).value = "100"

　　　　.Cells(2, 2).value = "200"

　　　　.Cells(3, 2).value = "=SUM(B1:B2)"

　　　　.Cells(1, 3).value = "中国人民解放军"

　　　　.Range("A3:A9") = "50"

　　End With

　zsbexcel.ActiveSheet.PageSetup.Orientation = xlPortrait　　　 '

xlLandscape

　zsbexcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4

　zsbexcel.ActiveSheet.PrintOut

　zsbexcel.DisplayAlerts = False

　zsbexcel.Quit

　zsbexcel.DisplayAlerts = True

　Set zsbexcel = Nothing

提高EXCEL中VBA的效率

　　方法1：尽量使用VBA原有的属性、方法和Worksheet函数

　　由于Excel对象多达百多个，对象的属性、方法、事件多不胜数，对于初学者来说可能对它们不全部了解，这就产生了编程者经常编写与Excel对象的属性、方法相同功能的VBA代码段，而这些代码段的运行效率显然与Excel对象的属性、方法完成任务的速度相差甚大。例如用Range的属性CurrentRegion来返回 Range 对象，该对象代表当前区。（当前区指以任意空白行及空白列的组合为边界的区域）。同样功能的VBA代码需数十行。因此编程前应尽可能多地了解Excel对象的属性、方法。

　　充分利用Worksheet函数是提高程序运行速度的极度有效的方法。如求平均工资的例子：For Each c In Worksheet(1).Range(″A1:A1000″)

　　 Totalvalue = Totalvalue ＋ c.value

　　Next

　　Averagevalue = Totalvalue / Worksheet(1).Range(″A1:A1000″).Rows.Count

　　而下面代码程序比上面例子快得多：

　　Averagevalue=Application.WorksheetFunction.Average(Worksheets(1).Range(″A1:A1000″))

　　其它函数如Count,Counta,Countif,Match,Lookup等等，都能代替相同功能的VBA程序代码，提高程序的运行速度。

　　方法2：尽量减少使用对象引用，尤其在循环中

　　每一个Excel对象的属性、方法的调用都需要通过OLE接口的一个或多个调用，这些OLE调用都是需要时间的，减少使用对象引用能加快VBA代码的运行。例如

　　1．使用With语句。

　　 Workbooks(1).Sheets(1).Range(″A1:A1000″).Font.Name=″Pay″

　　 Workbooks(1).Sheets(1).Range(″A1:A1000″).Font.FontStyle=″Bold″ ...

　　则以下语句比上面的快

　　With Workbooks(1).Sheets(1).Range(″A1:A1000″).Font

　　 .Name = ″Pay″

　　 .FontStyle = ″Bold″

　　 ...

　　End With

　　2．使用对象变量。

　　 如果你发现一个对象引用被多次使用，则你可以将此对象用Set 设置为对象变量，以减少对对象的访问。如：

　　Workbooks(1).Sheets(1).Range(″A1″).value = 100

　　 Workbooks(1).Sheets(1).Range(″A2″).value = 200

　　则以下代码比上面的要快：

　　Set MySheet = Workbooks(1).Sheets(1)

　　MySheet.Range(″A1″).value = 100

　　MySheet.Range(″A2″).value = 200

　　3．在循环中要尽量减少对象的访问。

　　For k = 1 To 1000

　　 Sheets(″Sheet1″).Select

　　 Cells(k,1).value = Cells(1,1).value

　　Next k

　　则以下代码比上面的要快：

　　Set Thevalue = Cells(1,1).value

　　Sheets(″Sheet1″).Select

　　For k = 1 To 1000

　　 Cells(k,1).value = Thevalue

　Next k

　　方法3：减少对象的激活和选择

　　如果你的通过录制宏来学习VBA的，则你的VBA程序里一定充满了对象的激活和选择，例如Workbooks(XXX).Activate、Sheets(XXX).Select、Range(XXX).Select等,但事实上大多数情况下这些操作不是必需的。例如

　　Sheets(″Sheet3″).Select

　　Range(″A1″).value = 100

　　Range(″A2″).value = 200

　可改为：

　　With Sheets(″Sheet3″)

　　 .Range(″A1″).value = 100

　　 .Range(″A2″).value = 200

　　End With

　　方法4：关闭屏幕更新

　　如果你的VBA程序前面三条做得比较差，则关闭屏幕更新是提高VBA程序运行速度的最有效的方法，缩短运行时间2/3左右。关闭屏幕更新的方法：

　　Application.ScreenUpdate = False

　　请不要忘记VBA程序运行结束时再将该值设回来：

　　Application.ScreenUpdate = True

　　以上是提高VBA运行效率的比较有效的几种方法

本示例重复最近用户界面命令。本示例必须放在宏的第一行。

Application.Repeat

下例中，变量 counter 代替了行号。此过程将在单元格区域 C1:C20 中循环，将所有绝对值小于 0.01 的数字都设置为 0（零）。

Sub RoundToZero1()

For Counter = 1 To 20

Set curCell = Worksheets("Sheet1").Cells(Counter, 3)

If Abs(curCell.Value) < 0.01 Then curCell.Value = 0

Next Counter

End Sub

述过程在单元格区域 A1:D10 中循环，将所有绝对值小于 0.01 的数字都设置为 0（零）。

Sub RoundToZero2()

For Each c In Worksheets("Sheet1").Range("A1:D10").Cells

If Abs(c.Value) < 0.01 Then c.Value = 0

Next

End Sub

下述过程在工作表上运行时，将在活动单元格周围的区域内循环，将所有绝对值小于 0.01 的数字都设置为 0（零）。

Sub RoundToZero3()

For Each c In ActiveCell.CurrentRegion.Cells

If Abs(c.Value) < 0.01 Then c.Value = 0

Next

End Sub

下述过程在工作的空行写入数据

Sub 输入()

x = 3 '从第3行开始

Do While Not (IsEmpty(Cells(x, 2).Value)) '判断第2列的最后一行(即空行的上一行)

x = x + 1 '在最后一行加一行即为空行

Loop

'以下为写入数据

Cells(x, 1) = Sheets("sheet1").Cells(1, 3)

Cells(x, 2) = Sheets("sheet1").Cells(2, 3)

Cells(x, 3) = Sheets("sheet1").Cells(3, 3)

Cells(x, 4) = Sheets("sheet1").Cells(4, 3)

Sheets("sheet1").Select

Cells(2, 3) = Cells(2, 3) + 1 '每写一行自动加入序列号

Sheets("sheet2").Select

End Sub

Sub 每日结帐()

' 录入发生额 Macro

' 30 记录的宏 2002-12-18

Application.ScreenUpdating = False '关闭屏幕显示

If Application.InputBox("请输入密码：") = 1234 Then '此行与倒数3-5行设置密码

Dim Msg, Style, Title, X, MyString '设置变量

Msg = "！！！结帐后不能恢复，结帐吗？" ' 定义信息。

Style = vbYesNo + vbCritical + vbDefaultButton2 ' 定义按钮。

Title = "本日结帐！" ' 定义标题。

X = MsgBox(Msg, Style, Title)

If X = vbYes Then ' 用户按下“是”。

Close

Call 备份

Call 重算所有表

Sheets("日报表").Select

ActiveSheet.Unprotect

Selection.AutoFilter Field:=1 '全部显示

Sheets("余额表").Select

ActiveSheet.Unprotect

Selection.AutoFilter Field:=1 '全部显示

Range("e6:g183,i6:k183").Copy

Sheets("日报表").Select

Range("n6").Select

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

, AllowSorting:=True, AllowFiltering:=True

[A2].Copy

Sheets("银行帐").Select

Range("F2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

, AllowSorting:=True, AllowFiltering:=True

Application.CutCopyMode = False

End If

Else: MsgBox "密码错误，即将退出！" '此行与第2行共同设置密码

End If

Application.ScreenUpdating = True '打开屏幕显示

End Sub

Sub 月末结帐()

Application.ScreenUpdating = False

If Application.InputBox("请输入密码：") = 1234 Then '此行与倒数3-5行设置密码

'以下三行为消息框

Dim Msg, Style, Title, X, MyString

Msg = "！！！结帐后不能恢复，结帐吗？" ' 定义信息。

Style = vbYesNo + vbCritical + vbDefaultButton2 ' 定义按钮。

Title = "月末结帐！" ' 定义标题。

X = MsgBox(Msg, Style, Title)

If X = vbYes Then ' 用户按下“是”。

Close

Call 备份

Call 重算所有表

Sheets("余额表").Select

[L6:L183].Copy

Sheets("日报表").Select

Range("M6").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Range("N6").Select

[N6:S183] = ""

Sheets("银行帐").Select

[A7:u3000] = ""

[K5].Copy

Range("K6").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

Range("A1").Select

End If

Else: MsgBox "密码错误，即将退出！" '此行与第2行共同设置密码

End If

Application.ScreenUpdating = True

End Sub

Sub 打日报表()

Application.ScreenUpdating = False

Sheets("日报表").Select

Call 重算所有表

ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码

Selection.AutoFilter Field:=1, Criteria1:="1.00 "

'自动筛选

'以下10行弹出窗口输入打印信息

Dim myPrintNum As Integer

Dim myPrompt, myTitle As String

myPrompt = "请输入要打印的份数"

myTitle = "打印选取范围"

myPrintNum = Application.InputBox(myPrompt, myTitle, 4, , , , , 1)

If myPrintNum <> 0 Then

' Application.ActivePrinter = "//zdserver2/HP LaserJet 5000 PCL 6 在 Ne00:" '指定打印机

ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum, Collate:=True '设置打印信息,其中Copies:=myPrint为打印份数

Else

MsgBox "请输入要打印的份数"

End If

ActiveSheet.ShowAllData '全部显示

ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码

Sheets("封面").Select

Application.ScreenUpdating = True

End Sub

Sub 打印余额()

Application.ScreenUpdating = False

Sheets("余额表").Select

Call 重算所有表

ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码

ActiveWindow.ScrollColumn = 10

Selection.AutoFilter Field:=1, Criteria1:="<>"

'以下10行弹出窗口输入打印信息

Dim myPrintNum As Integer

Dim myPrompt, myTitle As String

myPrompt = "请输入要打印的份数"

myTitle = "打印选取范围"

myPrintNum = Application.InputBox(myPrompt, myTitle, 4, , , , , 1)

If myPrintNum <> 0 Then

' Application.ActivePrinter = "//zdserver2/HP LaserJet 5000 PCL 6 在 Ne00:" ' '指定打印机

ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum, Collate:=True '设置打印信息,其中Copies:=myPrint为打印份数

Else

MsgBox "请输入要打印的份数"

End If

ActiveSheet.ShowAllData '全部显示

ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码

Sheets("封面").Select

Application.ScreenUpdating = True

End Sub

Sub 备份()

Dim y '变量声明-需保存工作表的路径和名称

[M1] = ActiveWorkbook.FullName '单元格M1=当前工作簿的路径和名称

y = cells(1, 14) 'Y=单元格N1的值,即计算后的需保存工作簿的路径和名称

Worksheets("封面").UsedRange.Columns("M:N").Calculate '计算指定区域

ActiveWorkbook.SaveCopyAs y '备份到指定路么Y

End Sub

Sub 重算活动表()

With Application

.Calculation = xlManual

.MaxChange = 0.001

End With

ActiveWorkbook.PrecisionAsDisplayed = True

ActiveWindow.DisplayZeros = True

ActiveSheet.Calculate

End Sub

Sub 重算指定表()

Attribute 重算指定表.VB_ProcData.VB_Invoke_Func = "z/n14"

Worksheets("银行帐").Calculate

Worksheets("日报表").Calculate

End Sub

单元格数据改变引起计算激活过程

Private Sub Worksheet_Change(ByVal Target As Range)

Dim irow, icol As Integer

irow = Target.Row '变量行irow

icol = Target.Column '变量列icol

If irow > 6 And icol = 3 And cells(irow, 3) >= cells(irow - 1, 3) Then '>大于6行,并且第3列,当本行 3列>2行3列

Application.EnableEvents = False

cells(irow, 2) = cells(irow - 1, 2) '本行 2 列=上一行2列

Application.EnableEvents = True

ElseIf irow > 6 And icol = 3 And cells(irow, 3) < cells(irow - 1, 3) Then '>大于6行,并且第3列,当本行 3列>2行3列

Application.EnableEvents = False

cells(irow, 2) = cells(irow - 1, 2) + 1 '本行 2 列=上行2列+1

Application.EnableEvents = True

ElseIf (icol = 3 Or icol = 4 Or icol = 6 Or icol = 8 Or icol = 9 Or icol = 10 Or icol = 12 Or icol = 13) And irow > 6 Then 'And Target <> ""

Application.EnableEvents = False

cells(irow, 5) = "=单位名称"

cells(irow, 7) = "=摘要"

cells(irow, 11) = "=余额"

Range(cells(irow, 14), cells(irow, 16)) = "=预内外收支NOP"

cells(irow, 17) = "=审核Q"

cells(irow, 18) = "=对帐U"

Range(cells(irow, 19), cells(irow, 20)) = "=内转收支XY"

cells(irow, 21) = "=政采Z"

Application.EnableEvents = True

End If

End Sub

'计算当前工作表路径及名称的函数,可作为单元格公式,也可写入宏

=CELL("FILENAME")

'改变Excel界面标题的宏

Private Sub Workbook_Open()

Application.Caption = "吃过了"

End Sub

'自动刷新单元格A1内显示的日期/时间的宏

Sub mytime()

Range("a1") = Now()

Application.OnTime Now + TimeValue("00:00:01"), "mytime"

End Sub

'用单元格A1的内容作为文件名保存当前工作簿的宏

Sub b()

ActiveWorkbook.SaveCopyAs Range("A1") + ".xls"

End Sub

'激活窗体的宏,此宏写入有窗体的工作表内

Private Sub CommandButton1_Click() '点数据录入按钮控件激活窗体

Load UserForm3 '激活窗体

UserForm3.StartUpPosition = 3 '激活窗体

UserForm3.Show '激活窗体

End Sub

'以下为窗体中点击各按钮运行的宏,写入窗体内

Public pos As Integer '声明变量pos

'战友确定按钮语句

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False '此句和最后一句旨在不显示宏的执行过程

'On Error GoTo ErrorHandle '可以不要

'ErrorHandle: '可以不要

'If Err.Number = 13 Then '可以不要

'Exit Sub '可以不要

'End If '可以不要

Call writeToWorkSheet '执行宏writetoworksheet

UserForm3.Hide '退出窗体,继续按钮少此句,退出按钮执行此句

Unload UserForm3 '退出窗体,继续按钮少此句,退出按钮执行此句

Call 批量打印 '[此处到接顺序2]

[L2] = "" '[到此处结束]

Sheets("打印信息").Select

Application.ScreenUpdating = True

End Sub

'退出按钮语句

Private Sub CommandButton2_Click()

UserForm3.Hide

Unload UserForm3

End Sub

'将窗体内的文本框中的数据写进工作表的单元格

Private Sub writeToWorkSheet()

ActiveSheet.Range("k2") = TextBox1.Value '将文字框内容写进k列

ActiveSheet.Range("l2") = TextBox2.Value '将文字框内容写进l列

TextBox1.Value = "" '清空文字框内容

TextBox2.Value = "" '清空文字框内容

Worksheets("打印信息").Range("a2").Value = 1 '给指定表的单元格写入数据

Worksheets("打印信息").Range("B3:E113").Value = "" '清空指定表的单元格数据

End Sub

'以下为根据条件打印的宏

Sub 打印() '部门明细查询及批星打印

Application.ScreenUpdating = False '关闭屏幕更新

If Cells(1, 4) = "" And Cells(1, 5) = "" Then '打印条件Cells(3, 13) = 1 And

' Application.ActivePrinter = "//zdserver2/HP LaserJet 5000 PCL 6 在 Ne00:" ' '指定打印机

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '设置默认打印机的打印信息,其中Copies:=myPrint为打印份数

Else

Call 打印信息 '打倒为假时执行

End If

Application.ScreenUpdating = True '关闭屏幕更新

End Sub

'以下的循环过程,也用于批量打印,Z的值可以是Z=1 TO 5(1到5),也可是单元格的内容

Sub 批量打印()

For Z = Cells(1, 11) To Cells(1, 12) '变量X的值从打印起始号K1到结束号L1之间逐渐递增

Cells(1, 13) = Z 'M1的值等于变量X

Next Z

End Sub