自来水管堵漏:VBA技术技巧收集(二)-

VBA技术技巧收集(二)
fanjy 发表于 2007-2-9 10:49:00 本辑目录：
[005] 从已关闭的工作簿中复制单元格区域
[006] 从已关闭的工作簿中获取该工作簿中的工作表名称
[007] 在VBA中使用DOS命令 = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
[005] 从已关闭的工作簿中复制单元格区域
下面分别介绍了从本计算机文件夹、网络计算机文件夹和Internet中已关闭的工作簿取值的技术。这三种情况均使用了同一个VBA过程GetRange。(来源于Ron de Bruin)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
GetRange过程：
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
             SourceRange As String, DestRange As Range)
    Dim Start
    '定位到目标单元格区域
    Application.Goto DestRange
    '调整目标区域的大小与源区域SourceRange大小相同
    Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
                                     Range(SourceRange).Columns.Count)
    '添加对已关闭文件的链接
    With DestRange
        .FormulaArray = "='" & FilePath & "/[" & FileName & "]" & SheetName _
                        & "'!" & SourceRange
        '等待
        Start = Timer
        Do While Timer < Start + 2
            DoEvents
        Loop
        '取值
        .Copy
        .PasteSpecial xlPasteValues
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
End Sub
说明：本过程有5个参数，分别为(1)文件路径；(2)文件名；(3)源工作表名；(4)源单元格区域；(5)目标工作表/区域。
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
第1种情况：从本地文件夹的工作簿中取值
Sub File_In_Local_Folder()
    Application.ScreenUpdating = False
    On Error Resume Next
    '调用GetRange
    GetRange "C:\Data", "test1.xls", "Sheet1", "A1:B100", _
             Sheets("Sheet1").Range("A1")
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
第2种情况：从网络计算机文件夹的工作簿中取值
Sub File_In_Network_Folder()
    Application.ScreenUpdating = False
    On Error Resume Next
    '调用GetRange
    GetRange "\\Jdb\shareddocs", "test2.xls", "Sheet1", "A1:B100", _
             Sheets("Sheet1").Range("A1")
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
第3种情况：从Internet网络文件工作簿中取值
Sub File_On_Website()
    Application.ScreenUpdating = False
    On Error Resume Next
    '调用GetRange
    GetRange "files", "test3.xls", "Sheet1", "A1:B100", _
             Sheets("Sheet1").Range("A1")
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
[006] 从已关闭的工作簿中获取该工作簿中的工作表名称
可以使用ADO查询工作簿来获取该工作簿所包含的工作表。ADO将工作簿作为一个数据库，每个工作表作为一个表。下面的示例代码使用了一些技巧，从一个关闭的工作簿中返回该工作簿内所有工作表名称。适用于Excel 2000及以后的版本。(来源于appspro.com)
Public Sub DemoGetSheetNames()
    Dim lNumEntries As Long
    Dim szFullName As String
    Dim aszSheetList() As String
   
    Sheet1.UsedRange.Clear
    szFullName = CStr(Application.GetOpenFilename("Excel Files (*.xls),*.xls", , "选择一个Excel文件"))
    '如果用户没有单击删除按钮则继续
    If szFullName <> CStr(False) Then
        GetSheetNames szFullName, aszSheetList()
        lNumEntries = UBound(aszSheetList) - LBound(aszSheetList) + 1
        Sheet1.Range("A1").Resize(lNumEntries).Value = Application.WorksheetFunction.Transpose(aszSheetList())
        Sheet1.Range("A1").EntireColumn.AutoFit
    End If
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 返回指定工作簿内包含的工作表列表字符串数组
''' 注:需要添加下面对象库引用(较高版本也可以)：
'''    * Microsoft ActiveX Data Objects 2.5 Library
'''    * Microsoft ADO Ext. 2.5 for DDL and Security
'''
''' 参数:  szFullName      想要查询工作表列表的工作簿的完整路径和全名
'''        aszSheetList()   存放通过szFullName指定的工作簿中工作表名列表
'''
Private Sub GetSheetNames(ByRef szFullName As String, ByRef aszSheetList() As String)
    Dim bIsWorksheet As Boolean
    Dim objConnection As ADODB.Connection
    Dim objCatalog As ADOX.Catalog
    Dim objTable As ADOX.Table
    Dim lIndex As Long
    Dim szConnect As String
    Dim szSheetName As String

    Erase aszSheetList()
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & szFullName & ";Extended Properties=Excel 8.0;"

    Set objConnection = New ADODB.Connection
    objConnection.Open szConnect
    Set objCatalog = New ADOX.Catalog
    Set objCatalog.ActiveConnection = objConnection

    For Each objTable In objCatalog.Tables
        bIsWorksheet = False
        szSheetName = objTable.Name
        If Right$(szSheetName, 1) = "$" Then
            ''' 工作表名，移除后面的"$"
            szSheetName = Left$(szSheetName, Len(szSheetName) - 1)
            bIsWorksheet = True
        ElseIf Right$(szSheetName, 2) = "$'" Then
            ''' 工作表名，带有空格或特定字符，移除右侧的字符"&'"
            szSheetName = Left$(szSheetName, Len(szSheetName) - 2)
            ''' 移除单引号
            szSheetName = Right$(szSheetName, Len(szSheetName) - 1)
            ''' 在工作表名中嵌入的单引号将成为两个单引号
            ''' 用一个单引号代替任何双重单引号
            szSheetName = Replace$(szSheetName, "''", "'")
            bIsWorksheet = True
        End If
        If bIsWorksheet Then
            ''' 将工作表名放入数组
            ReDim Preserve aszSheetList(0 To lIndex)
            aszSheetList(lIndex) = szSheetName
            lIndex = lIndex + 1
        End If
    Next objTable

    objConnection.Close
    Set objCatalog = Nothing
    Set objConnection = Nothing
End Sub
提示：在运行上面的程序前，需要添加下面对象库引用(较高版本也可以)：
    * Microsoft ActiveX Data Objects 2.5 Library
* Microsoft ADO Ext. 2.5 for DDL and Security
方法是在VBE编辑器中，单击菜单“工具>>引用”，在出现的“引用”对话框中将相应对象库前的复选框选中。 单击此处下载示例
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
[007] 在VBA中使用DOS命令
下面的代码将存放在F盘“我的文件”文件夹中的文件复制到C盘“我的XLS文件备份”文件夹中。
Sub test()
    Dim retval
    retval = Shell("XCOPY F:\我的文件\*.* C:\我的XLS文件备份/E", 0)
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
加上更多的DOS参数，如/D 2007-2-5，即复制指定日期的文件。
Sub test()
    Dim str As String
    str = "XCOPY C:\SourceFolder\*.* C:\BACKUPS\*.* /E /D:" & Format(Date - 7, "mm-dd-yyyy")
    Shell str
End Sub
上面的代码将源文件夹中7天前的文件复制到备份文件夹中。
(来源于vbaexpress.com)
有关Shell函数更详细的介绍请见EH论坛上agstick的贴子(细说shell函数——不得不看！)
分类:ExcelVBA>>技术技巧
By fanjy in 2007-2-9