本輯目錄：[005] 從已關(guān)閉的工作簿中復(fù)制單元格區(qū)域
[006] 從已關(guān)閉的工作簿中獲取該工作簿中的工作表名稱(chēng)
[007] 在VBA中使用DOS命令 = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = [005] 從已關(guān)閉的工作簿中復(fù)制單元格區(qū)域
下面分別介紹了從本計(jì)算機(jī)文件夾、網(wǎng)絡(luò)計(jì)算機(jī)文件夾和Internet中已關(guān)閉的工作簿取值的技術(shù)。這三種情況均使用了同一個(gè)VBA過(guò)程GetRange。(來(lái)源于 Ron de Bruin) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - GetRange過(guò)程： Sub GetRange(FilePath As String, FileName As String, SheetName As String, _ SourceRange As String, DestRange As Range) Dim Start '定位到目標(biāo)單元格區(qū)域
Application.Goto DestRange '調(diào)整目標(biāo)區(qū)域的大小與源區(qū)域SourceRange大小相同
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _ Range(SourceRange).Columns.Count) '添加對(duì)已關(guān)閉文件的鏈接
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 說(shuō)明：本過(guò)程有5個(gè)參數(shù)，分別為(1)文件路徑；(2)文件名；(3)源工作表名；(4)源單元格區(qū)域；(5)目標(biāo)工作表/區(qū)域。 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 第1種情況：從本地文件夾的工作簿中取值 Sub File_In_Local_Folder() Application.ScreenUpdating = False On Error Resume Next '調(diào)用GetRange
GetRange "C:\Data", "test1.xls", "Sheet1", "A1:B100", _ Sheets("Sheet1").Range("A1") On Error GoTo 0 Application.ScreenUpdating = True End Sub - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 第2種情況：從網(wǎng)絡(luò)計(jì)算機(jī)文件夾的工作簿中取值 Sub File_In_Network_Folder() Application.ScreenUpdating = False On Error Resume Next '調(diào)用GetRange
GetRange " \\Jdb\shareddocs", "test2.xls", "Sheet1", "A1:B100", _ Sheets("Sheet1").Range("A1") On Error GoTo 0 Application.ScreenUpdating = True End Sub - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 第3種情況：從Internet網(wǎng)絡(luò)文件工作簿中取值 Sub File_On_Website() Application.ScreenUpdating = False On Error Resume Next '調(diào)用GetRange
GetRange " Sheets("Sheet1").Range("A1")
On Error GoTo 0
Application.ScreenUpdating = True
End Sub= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
[006] 從已關(guān)閉的工作簿中獲取該工作簿中的工作表名稱(chēng)
可以使用ADO查詢(xún)工作簿來(lái)獲取該工作簿所包含的工作表。ADO將工作簿作為一個(gè)數(shù)據(jù)庫(kù)，每個(gè)工作表作為一個(gè)表。下面的示例代碼使用了一些技巧，從一個(gè)關(guān)閉的工作簿中返回該工作簿內(nèi)所有工作表名稱(chēng)。適用于Excel 2000及以后的版本。(來(lái)源于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", , "選擇一個(gè)Excel文件"))
'如果用戶(hù)沒(méi)有單擊刪除按鈕則繼續(xù)
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 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 返回指定工作簿內(nèi)包含的工作表列表字符串?dāng)?shù)組
''' 注:需要添加下面對(duì)象庫(kù)引用(較高版本也可以)：
''' * Microsoft ActiveX Data Objects 2.5 Library
''' * Microsoft ADO Ext. 2.5 for DDL and Security
'''
''' 參數(shù): szFullName 想要查詢(xún)工作表列表的工作簿的完整路徑和全名
''' aszSheetList() 存放通過(guò)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
''' 工作表名，帶有空格或特定字符，移除右側(cè)的字符"&'"
szSheetName = Left$(szSheetName, Len(szSheetName) - 2)
''' 移除單引號(hào)
szSheetName = Right$(szSheetName, Len(szSheetName) - 1)
''' 在工作表名中嵌入的單引號(hào)將成為兩個(gè)單引號(hào)
''' 用一個(gè)單引號(hào)代替任何雙重單引號(hào)
szSheetName = Replace$(szSheetName, "''", "'")
bIsWorksheet = True
End If
If bIsWorksheet Then
''' 將工作表名放入數(shù)組
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
提示：在運(yùn)行上面的程序前，需要添加下面對(duì)象庫(kù)引用(較高版本也可以)：
* Microsoft ActiveX Data Objects 2.5 Library
* Microsoft ADO Ext. 2.5 for DDL and Security
方法是在VBE編輯器中，單擊菜單“工具>>引用”，在出現(xiàn)的“引用”對(duì)話(huà)框中將相應(yīng)對(duì)象庫(kù)前的復(fù)選框選中。 單擊此處下載示例= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = [007] 在VBA中使用DOS命令
下面的代碼將存放在F盤(pán)“我的文件”文件夾中的文件復(fù)制到C盤(pán)“我的XLS文件備份”文件夾中。 Sub test() Dim retval retval = Shell("XCOPY F:\我的文件\*.* C:\我的XLS文件備份/E", 0) End Sub - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 加上更多的DOS參數(shù)，如/D 2007-2-5，即復(fù)制指定日期的文件。 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天前的文件復(fù)制到備份文件夾中。 (來(lái)源于vbaexpress.com) 有關(guān)Shell函數(shù)更詳細(xì)的介紹請(qǐng)見(jiàn)EH論壇上agstick的貼子( 細(xì)說(shuō)shell函數(shù)——不得不看！) 分類(lèi):ExcelVBA>>技術(shù)技巧By fanjy in 2007-2-9 | 
