完美Excel

在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过程后，结果如下图所示：

正则表达式是一种强大的工具，也有人称之为一门语言。今天，学习了一些正则表达式的知识以及在Excel中使用正则表达式（Regular Expression）的知识，先记录下来，方便以后进一步学习。

首先，引用Microsoft VBScript Regular Expressions 5.5类库。

然后，在标准模块中输入下面的代码进行测试：

   1: Option Explicit

   2: 

   3: Sub Test()

   4:     Dim strPhone As String

   5:

   6:     strPhone = "719-499-2312"

   7:

   8:     If qstr_BeginsWith(strPhone, "719") Then

   9:         Debug.Print "yes"

  10:     Else

  11:         Debug.Print "no"

  12:     End If

  13:

  14: End Sub

  15: 

  16: Function qstr_BeginsWith(strMain As String, strPart As String) As Boolean

  17:     Dim reg As New VBScript_RegExp_55.RegExp

  18:     reg.Pattern = strPart

  19:     qstr_BeginsWith = reg.Test(strMain)

  20: End Function

运行Test过程后，将输出“yes”。

上面是一个很简单的例子。接下来，将结合正则表达式知识的学习并看几段程序，进一步认识正则表达式的使用。这些程序都是在vbaexpress、dicks-blog等Excel论坛和博客中找到的。

Technorati 标签: Regular Expressions,正则表达式,Excel VBA

据百度百科的描述：
汉诺塔（又称河内塔）问题是印度的一个古老的传说。开天辟地的神勃拉玛在一个庙里留下了三根金刚石的棒，第一根上面套着64个圆的金片，最大的一个在底下，其余一个比一个小，依次叠上去，庙里的众僧不倦地把它们一个个地从这根棒搬到另一根棒上，规定可利用中间的一根棒作为帮助，但每次只能搬一个，而且大的不能放在小的上面。面对庞大的数字(移动圆片的次数)18446744073709551615，看来，众僧们耗尽毕生精力也不可能完成金片的移动。
后来，这个传说就演变为汉诺塔游戏：
1、有三根杆子A,B,C。A杆上有若干碟子
2、每次移动一块碟子，小的只能叠在大的上面
3、把所有碟子从A杆全部移到C杆上
经过研究发现，汉诺塔的破解很简单，就是按照移动规则向一个方向移动金片：
如3阶汉诺塔的移动：A→C,A→B,C→B,A→C,B→A,B→C,A→C
此外，汉诺塔问题也是程序设计中的经典递归问题。
算法思路：
1、如果只有一个金片，则把该金片从源移动到目标棒，结束。
2、如果有n个金片，则把前n-1个金片移动到辅助的棒，然后把自己移动到目标棒，最后再把前n-1个移动到目标棒
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
这是一个很有趣的问题，也是一个迷人的问题，相信学过计算机特别是递归的朋友都熟悉这个经典的问题。问题简单描述如下：
设有3根标号为A，B，C的柱子，在A柱上放着n个盘子，每一个都比下面的略小一点，要求把A柱上的盘子全部移到C柱上，移动的规则是：（1）一次只能移动一个盘子；（2）移动过程中大盘子不能放在小盘子上面；（3）在移动过程中盘子可以放在A，B，C的任意一个柱子上。
其解答的基本思想是使用递归的方式：
1、1个盘子的汉诺塔问题可直接移动。
2、n个盘子的汉诺塔问题可递归表示为，首先把上边的n-1个盘子借助于C柱从A柱移到B柱，然后把最下边的一个盘子从A柱移到C柱，最后把移到B柱的n-1个盘子借助于A柱再移到C柱。4个盘子汉诺塔问题的递归求解示意图如图所示。

程序代码：
Option Explicit
Dim Counter As IntegerSub GetMove()
    Dim n As Integer
    On Error Resume Next
    n = Application.InputBox(Prompt:=”请输入一个代表要移动盘子的数量值:”, _
                                  Title:=”汉诺塔问题”, _
                                  Type:=2)
    Call Move(n, “A”, “B”, “C”)
End Sub