存档在 ‘ExcelVBA程序’ 分类中.
下面的内容及程序代码模仿自《Excel 2007 VBA Programmer’s Reference》，可能在某些情形下极其有用，因此特辑录于此，供参考。
如下图所示，双击工作表Sheet1的列A中的任一单元格，将出现一组合框，允许用户选择其中的项目。当用户选取某项目后，将自动输入到该单元格，并在该单元格右侧的单元格中输入相应的价格数字，组合框同时消失。
下面是程序代码。在工作表Sheet1的代码模块中输入BeforeDoubleClick事件代码：
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Columns(”A”)) Is Nothing Then
Call AddDropDown(Target)
Cancel = True
End If
End Sub
在任一模块中，输入下面的代码：
Sub AddDropDown(Target As Range)
Dim ddBox As DropDown
Dim vProducts As Variant
Dim i As Integer
‘创建产品数组
vProducts = Array(”香蕉”, “苹果”, “菠萝”, “葡萄”)
‘在目标单元格中添加下拉控件
With Target
Set ddBox = Sheet1.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
‘定义执行的宏并填充列表
With ddBox
.OnAction = “EnterProdInfo”
For i = LBound(vProducts) To UBound(vProducts)
.AddItem vProducts(i)
Next i
End With
End Sub
Private Sub EnterProdInfo()
Dim vPrices As Variant
‘创建价格数组
vPrices = Array(6, 8, 5, 4)
‘输入所选项到相应的单元格
With Sheet1.DropDowns(Application.Caller)
.TopLeftCell.Value = .List(.ListIndex)
.TopLeftCell.Offset(0, 1).Value = vPrices(.ListIndex + LBound(vPrices) - 1)
‘删除
.Delete
End With
End Sub
如下图所示：
有许多种从关闭的工作簿中取值的方法，下面是其中之一。下面的VBA代码从关闭的工作簿中获取值。
Sub ExtractDataFromClosedWorkBook()
Application.ScreenUpdating = False
‘创建链接来从关闭的工作簿中获取数据
‘可以将相关代码修改为相应的路径和单元格
With [Sheet1!A1:B4]
.Value = “=’” & ActiveWorkbook.Path & “\[testDataWorkbook.xls]Sheet1′!A1:B4″
‘删除链接
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
其中，可以将代码中的路径修改为需要从中获取值的工作簿的路径，单元格也作相应的修改。
在dicks的blog中看到了一段解决同名文件问题的程序解决方案，贴出来共享。
有时，必须存储一个名称与现有文件名相同的文件，此时可以在名称末尾添加数字使其唯一。但问题是该文件将放在三个不同的文件夹中：Working、Review和Archive，需要在这三个文件夹中检查相同的文件名称。
现在，创建一个函数来返回下一个可用的后缀，如果没有相同的文件存在，返回空字符串；如果有相同的文件存在，则返回能够添加到文件名后使其唯一的数字。
该函数遍历文件夹并使用Dir函数来获取相同的名称。为了使用Dir，将搜索的文件更改为包含有星号（*），例如名称为MyFile.xls的成为MyFile*.xls，并且将查找MyFile.xls、MyFile1.xls等等。如果找到匹配项，将分隔数字并记录下最终找到的最大的一个数字。如果没有数字，Replace语句返回一个空字符串并且Val函数将其转换为0。
Function GetUniqueSuffix(sName As String, vaFolders As Variant) As String
Dim lSuffix As Long, lMax As Long
Dim sDirName As String
Dim sBaseName As String
Dim i As Long
Dim sTempName As String
Const sEXTENSION As String = “.xls”
sDirName = Replace(sName, sEXTENSION, “*” & sEXTENSION)
sBaseName = Replace(sName, sEXTENSION, “”)
For i = LBound(vaFolders) To UBound(vaFolders)
sTempName = Dir(vaFolders(i) & sDirName)
Do Until Len(sTempName) = 0
lSuffix = Val(Replace(Replace(sTempName, sBaseName, “”), sEXTENSION, “”)) + 1
If lSuffix > lMax Then
lMax = lSuffix
End If
sTempName = Dir
Loop
Next i
If lMax > 0 Then
GetUniqueSuffix = CStr(lMax)
Else
GetUniqueSuffix = “”
End If
End Function
使用示例:
Sub UniqueSuffixExample()
Dim vaFolders As Variant
Dim sFile As String
Dim lUnique As Long
vaFolders = Array(”C:\Working\”, “C:\Review\”, “C:\Archive\”)
sFile = “MyFile.xls”
lUnique = GetUniqueSuffix(sFile, vaFolders)
sFile = Replace(sFile, “.xls”, lUnique & “.xls”)
ActiveWorkbook.SaveAs “C:\Working\” & sFile
End Sub
近期正在利用Excel开发一套工作管理系统，已初步有了结果，并开始使用。前不久，在一篇博客文章中，我贴出了该系统的主界面。在这里，随便谈谈在开发过程中的一些心得体会，供大家参考。
在同一工作簿中不要试图处理所有需要实现的任务。当然，如果您的系统只需实现少有的几项功能，在一个工作簿中集中实现这几项功能是简单方便的。但是，如果需要实现多项任务，特别是需要处理大量数据的情形下，建议将任务进行整合分类，分别放在不同的工作簿中来实现这些任务。
此时，需要规划好各工作簿要实现的功能任务，合理设计各个工作簿之间的关系，理顺各工作簿之间的数据调用，并且使用一个主工作簿来调用各个工作簿，这样使得系统非常灵活、精简，也不致于因使用而致使工作簿体积快速不断增大。
要注意的是，对于存在数据调用的工作簿，一定要清楚调用的顺序，避免因为某一工作簿数据的更换而影响其他相关工作簿数据的准确性。例如，工作簿B需要调用工作簿A中的数据，如果工作簿A中的数据发生变化，那么要及时更新工作簿B中的数据。
为工作簿添加自定义文档属性（即CustomDocumentProperties
属性），从而利用该属性来查找工作簿，或者判断是否为要查找的工作簿，或者能够合并同类工作簿。特别是在有大量名称会发生变化的工作簿时。
单击菜单“文件”─—“属性”，选择“自定义”选项卡，在“名称”中输入相应的名称，在“取值”中输入“Yes”，然后单击“添加”按钮加入属性，如下图所示。
这样，在多个工作簿相互调用时，可以避免因工作簿名称改变而出现的无法找到工作簿的错误。
记得及早、适时地退出循环，特别是在存在大量数据而不得不逐一进行循环时。例如，下面的代码，必须在工作表中的第3行至第31行、第2列至第32列依次循环，当满足特定条件后，使用Exit Sub语句退出，从而避免继续循环。如果在更大范围内循环时更应如此。
For i = 3 To 31
‘循环每一列
For j = 2 To 32
If Target.Value = “” Then
If iTotalRow > 1 Then
For k = 2 To iTotalRow
If Target.Row = Worksheets(”Data”).Range(”A” & k) And Target.Column = Worksheets(”Data”).Range(”B” & k) Then
Worksheets(”Data”).Rows(k).EntireRow.Delete
bDecide = True
Exit Sub
End If
Next k
End If
End If
Next j
Next i
有时，需要在工作表中反复汇总或操作来自另一工作表或工作簿中的数据。记住，在将其他地方的数据复制到工作表中之前，记得清除以前的数据，避免产生重复数据或带来错误。
在我们编写程序的过程中，总有些代码适合于不同的程序开发。我们可以将这些程序代码做成通用程序，当需要时直接调用，从而节省时间，便于组织，提高了开发效率。这里，举几个例子。
（1）判断某文件是否存在
‘判断文件是否存在
Private Function FileExists(fname) As Boolean
‘如果存在则返回True
FileExists = (Dir(fname) <> “”)
End Function
（2）判断工作表是否存在
‘判断工作表是否存在
Private Function SheetExists(sName) As Boolean
‘如果当前工作簿中存在该工作表则返回True
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sName)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If
End Function
（3）返回满足查找条件的所有单元格组成的区域
‘通用的查找函数
Function FindAll(SearchRange As Range, FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False) As Range
”””””””””””””””””””””””””””””””””””””””””””””
‘ 返回SearchRange区域中含有FindWhat所代表的值的所有单元格组成的Range对象
‘ 其参数与Find方法的参数相同
‘ 如果没有找到单元格,将返回Nothing.
”””””””””””””””””””””””””””””””””””””””””””””
Dim FoundCell As Range
Dim FoundCells As Range
Dim LastCell As Range
Dim FirstAddr As String
With SearchRange
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = SearchRange.Find(what:=FindWhat, after:=LastCell, _
LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FoundCells = FoundCell
FirstAddr = FoundCell.Address
Do
Set FoundCells = Application.Union(FoundCells, FoundCell)
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
Loop Until (FoundCell Is Nothing) Or (FoundCell.Address = FirstAddr)
End If
If FoundCells Is Nothing Then
Set FindAll = Nothing
Else
Set FindAll = FoundCells
End If
End Function
大家在平时可以积累这些程序，既方便学习，又可以重用。
在《Excel & Access Integration：With Office 2007》的最后一章中，介绍了Microsoft Excel与Word、PowerPoint和Outlook整合的基本技术。其中，介绍Excel和PowerPoint整合技术时，演示了如何在Excel工作簿中创建演示文档，然后使用自动化将其转换为PowerPoint演示文档，如题。
我觉得这是一项非常有用的技术，充分发挥了两种应用程序各自的优点。在Excel工作簿中，每张工作表代表演示文档中的一张幻灯片，在工作表中能够充分利用Excel的数据分析和处理功能生成生动且有意义的图表或表格。然后，将这些工作表转换为PowerPoint幻灯片，从而利用PowerPoint的演示功能。
下面的示例沿用《Excel & Access Integration：With Office 2007》中的示例文档WorkbookToPowerPoint.xlsm，以演示这项技术。在该工作簿中，包含有四张工作表，分别包含四个区域（Asia、South America、United Kingdom、United States）的收入数据以及相应的图表分析（如下图所示）。
当然，这些工作表都是设计好了的，与PowerPoint中的幻灯片形式相同，每一张工作表代表一张幻灯片，分别演示一个区域的收入数据及分析情况。下面，我们将这些工作表转换为相应PowerPoint演示文档中的幻灯片。
首先，需要添加对Microsoft PowerPoint ╳╳ Object Library的引用（其中╳╳代表该对象库的版本号），如下图所示。
然后，在标准模块中输入下面的代码：
1: Sub WorkbooktoPowerPoint()
2:
3: ‘声明变量
4: Dim pp As PowerPoint.Application
5: Dim PPPres As PowerPoint.Presentation
6: Dim PPSlide As PowerPoint.Slide
7: Dim xlwksht As Excel.Worksheet
8: Dim MyRange As String
9: Dim MyTitle As String
10: Dim SlideCount As Integer
11:
12: ‘开启PowerPoint,添加新的演示文档并使其可见
13: Set pp = New PowerPoint.Application
14: Set PPPres = pp.Presentations.Add
15: pp.Visible = True
16:
17: ‘设置数据和标题的单元格区域
18: MyRange = “A1:I27″
19:
20: ‘开始循环每张工作表
21: For Each xlwksht In ActiveWorkbook.Worksheets
22: ‘设置每张幻灯片的标题
23: MyTitle = xlwksht.Range(“C19″).Value
24:
25: ‘复制单元格区域为图片
26: xlwksht.Range(MyRange).CopyPicture _
27: Appearance:=xlScreen, Format:=xlPicture
28:
29: ‘统计幻灯片并添加新幻灯片作为下一个可用的幻灯片号
30: SlideCount = PPPres.Slides.Count
31: Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
32: PPSlide.Select
33:
34: ‘粘贴图片并调整其位置
35: PPSlide.Shapes.Paste.Select
36: pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
37: pp.ActiveWindow.Selection.ShapeRange.Top = 100
38:
39: ‘为该幻灯片添加标题并移到下一张工作表
40: PPSlide.Shapes.Title.TextFrame.TextRange.Text = MyTitle
41: Next xlwksht
42:
43: ‘激活PPT演示文档
44: pp.Activate
45:
46: ‘释放内存
47: Set PPSlide = Nothing
48: Set PPPres = Nothing
49: Set pp = Nothing
50:
51: End Sub
第4行至第10行声明了7个变量。其中变量pp代表PowerPoint应用程序对象，变量PPPres代表PowerPoint的演示文档（Presentation）对象，变量PPSlide代表PowerPoint幻灯片（Slide）对象，变量xlwksht代表Worksheet对象，变量MyRange是一个字符串变量用来存储和传递单元格区域，变量MyTitle是一个字符串变量用来存储代表幻灯片标题的字符串，变量SlideCount是用于计数的整型变量。
第13行创建一个PowerPoint对象的新实例，第14行添加新的演示文档，第15行设置Visible属性为True，使PowerPoint可见。
第18行将希望作为幻灯片内容的区域赋值给变量MyRange。
第21行开始遍历工作簿中的每张工作表。
第23行将工作表中单元格C19中的内容赋值给变量MyTitle，作为每张幻灯片的标题。
第26行和第27行使用CopyPicture方法将指定的单元格区域作为图片。
第31行使用Slide对象的Add方法在演示文档中添加新幻灯片，其中变量SlideCount+1指定添加的幻灯片的索引号，并使用ppLayoutTitleOnly参数确保所创建的幻灯片带有标题文本框。
第35行至第37行粘贴图片到当前幻灯片中，并使图片水平居中且与顶部垂直距离为100像素。
第40行为该幻灯片添加标题。
第47至第49行释放对象变量所占用的内存。
运行WorkbooktoPowerPoint过程后，结果如下图所示：
标签: 没有标签
