工作簿(Workbook)基本操作应用示例(二)

工作簿(Workbook)基本操作应用示例(二)

---

<其它一些有关操作工作簿的示例>
示例03-25：创建新的工作簿
Sub testNewWorkbook()
MsgBox "创建一个带有10个工作表的新工作簿"
Dim wb as Workbook
Set wb = NewWorkbook(10)
End Sub
‘- - - - - - - - - - - - - - - - - - - - - - -
Function NewWorkbook(wsCount As Integer) As Workbook
'创建带有由变量wsCount提定数量工作表的工作簿，工作表数在1至255之间
Dim OriginalWorksheetCount As Long
  Set NewWorkbook = Nothing
  If wsCount < 1 Or wsCount > 255 Then Exit Function
  OriginalWorksheetCount = Application.SheetsInNewWorkbook
  Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
  Application.SheetsInNewWorkbook = OriginalWorksheetCount
End Function
示例说明：自定义函数NewWorkbook可以创建最多带有255个工作表的工作簿。本测试示例创建一个带有10个工作表的新工作簿。

---

示例03-26：判断工作簿是否存在
Sub testFileExists()
  MsgBox "如果文件不存在则用信息框说明,否则打开该文件."
  If Not FileExists("C:/文件夹/子文件夹/文件.xls") Then
    MsgBox "这个工作簿不存在!"
  Else
    Workbooks.Open "C:/文件夹/子文件夹/文件.xls"
  End If
End Sub
‘- - - - - - - - - - - - - - - - - - - - - - -
Function FileExists(FullFileName As String) As Boolean
  '如果工作簿存在,则返回True
  FileExists = Len(Dir(FullFileName)) > 0
End Function
示例说明：本示例使用自定义函数FileExists判断工作簿是否存在，若该工作簿已存在，则打开它。代码中，“C:/文件夹/子文件夹/文件.xls”代表工作簿所在的文件夹名、子文件夹名和工作簿文件名。

---

示例03-27：判断工作簿是否已打开
[示例03-27-01]
Sub testWorkbookOpen()
  MsgBox "如果工作簿未打开,则打开该工作簿."
  If Not WorkbookOpen("工作簿名.xls") Then
    Workbooks.Open "工作簿名.xls"
  End If
End Sub
‘- - - - - - - - - - - - - - - - - - - - - - -
Function WorkbookOpen(WorkBookName As String) As Boolean
  '如果该工作簿已打开则返回真
  WorkbookOpen = False
  On Error GoTo WorkBookNotOpen
  If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
    WorkbookOpen = True
    MsgBox "该工作簿已打开"
    Exit Function
  End If
WorkBookNotOpen:
End Function
示例说明：本示例中的函数WorkbookOpen用来判断工作簿是否打开。代码中，“工作簿名.xls”代表所要打开的工作簿名称。
[示例03-27-02]
Sub testWookbookIFOpen()
  Dim wb As String
  Dim bwb As Boolean
  wb = "<要判断的工作簿名称>"
  bwb = WorkbookIsOpen(wb)
  If bwb = True Then
    MsgBox "工作簿" & wb & "已打开."
  Else
    MsgBox "工作簿" & wb & "未打开."
  End If
End Sub
‘- - - - - - - - - - - - - - - - - - - - - - -
Private Function WorkbookIsOpen(wbname) As Boolean
  Dim x As Workbook
  On Error Resume Next
  Set x = Workbooks(wbname)
  If Err = 0 Then
    WorkbookIsOpen = True
  Else
    WorkbookIsOpen = False
  End If
End Function

---

示例03-28：备份工作簿
[示例03-28-01] 用与活动工作簿相同的名字但后缀名为.bak备份工作簿
Sub SaveWorkbookBackup()
  Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
  If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
  Set awb = ActiveWorkbook
  If awb.Path = "" Then
    Application.Dialogs(xlDialogSaveAs).Show
  Else
    BackupFileName = awb.FullName
    i = 0
    While InStr(i + 1, BackupFileName, ".") > 0
      i = InStr(i + 1, BackupFileName, ".")
    Wend
    If i > 0 Then BackupFileName = Left(BackupFileName, i - 1)
    BackupFileName = BackupFileName & ".bak"
    OK = False
    On Error GoTo NotAbleToSave
    With awb
      Application.StatusBar = "正在保存工作簿..."
      .Save
      Application.StatusBar = "正在备份工作簿..."
      .SaveCopyAs BackupFileName
      OK = True
    End With
  End If
NotAbleToSave:
  Set awb = Nothing
  Application.StatusBar = False
  If Not OK Then
    MsgBox "备份工作簿未保存!", vbExclamation, ThisWorkbook.Name
  End If
End Sub
示例说明：在当前工作簿中运行本示例代码后，将以与工作簿相同的名称但后缀名为.bak备份工作簿，且该备份与当前工作簿在同一文件夹中。其中，使用了工作簿的FullName属性和SaveCopyAs方法。
[示例03-28-02] 保存当前工作簿的副本到其它位置备份工作簿
Sub SaveWorkbookBackupToFloppyD()
  Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
  If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
  Set awb = ActiveWorkbook
  If awb.Path = "" Then
    Application.Dialogs(xlDialogSaveAs).Show
  Else
    BackupFileName = awb.Name
    OK = False
    On Error GoTo NotAbleToSave
    If Dir("D:/" & BackupFileName) <> "" Then
      Kill "D:/" & BackupFileName
    End If
    With awb
      Application.StatusBar = "正在保存工作簿..."
      .Save
      Application.StatusBar = "正在备份工作簿..."
      .SaveCopyAs "D:/" & BackupFileName
      OK = True
    End With
  End If
NotAbleToSave:
  Set awb = Nothing
  Application.StatusBar = False
  If Not OK Then
    MsgBox "备份工作簿未保存!", vbExclamation, ThisWorkbook.Name
  End If
End Sub
示例说明：本程序将把当前工作簿进行复制并以与当前工作簿相同的名称保存在D盘中。其中，使用了Kill方法来删除已存在的工作簿。

---

示例03-29：从已关闭的工作簿中取值
[示例03-29-01]
Sub testGetValuesFromClosedWorkbook()
  GetValuesFromAClosedWorkbook "C:", "Book1.xls", "Sheet1", "A1:G20"
End Sub
‘- - - - - - - - - - - - - - - - - - - - - - -
Sub GetValuesFromAClosedWorkbook(fPath As String, _
            fName As String, sName, cellRange As String)
  With ActiveSheet.Range(cellRange)
    .FormulaArray = "='" & fPath & "/[" & fName & "]" _
                    & sName & "'!" & cellRange
    .Value = .Value
  End With
End Sub
示例说明：本示例包含一个子过程GetValuesFromAClosedWorkbook，用来从已关闭的工作簿中获取数据，主过程testGetValuesFromClosedWorkbook用来传递参数。本示例表示从C盘根目录下的Book1.xls工作簿的工作表Sheet1中的A1:G20单元格区域内获取数据，并将其复制到当前工作表相应单元格区域中。
[示例03-29-02]
Sub ReadDataFromAllWorkbooksInFolder()
  Dim FolderName As String, wbName As String, r As Long, cValue As Variant
  Dim wbList() As String, wbCount As Integer, i As Integer
  FolderName = "C:/文件夹名"
  '创建文件夹中工作簿列表
  wbCount = 0
  wbName = Dir(FolderName & "/" & "*.xls")
  While wbName <> ""
    wbCount = wbCount + 1
    ReDim Preserve wbList(1 To wbCount)
    wbList(wbCount) = wbName
    wbName = Dir
  Wend
  If wbCount = 0 Then Exit Sub
  '从每个工作簿中获取数据
  r = 0
  Workbooks.Add
  For i = 1 To wbCount
    r = r + 1
    cValue = GetInfoFromClosedFile(FolderName, wbList(i), "Sheet1", "A1")
    Cells(r, 1).Formula = wbList(i)
    Cells(r, 2).Formula = cValue
  Next i
End Sub
‘- - - - - - - - - - - - - - - - - - - - - - -
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
    wbName As String, wsName As String, cellRef As String) As Variant
  Dim arg As String
  GetInfoFromClosedFile = ""
  If Right(wbPath, 1) <> "/" Then wbPath = wbPath & "/"
  If Dir(wbPath & "/" & wbName) = "" Then Exit Function
  arg = "'" & wbPath & "[" & wbName & "]" & _
        wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
  On Error Resume Next
  GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
示例说明：本示例将读取一个文件夹内所有工作簿中工作表Sheet1上单元格A1中的值到一个新工作簿中。代码中，“C:/文件夹名”代表工作簿所在的文件夹名。
[示例03-29-03]
Sub GetDataFromClosedWorkbook()
  Dim wb As Workbook
  Application.ScreenUpdating = False
  '以只读方式打开工作簿
  Set wb = Workbooks.Open("C:/文件夹名/文件.xls", True, True)
  With ThisWorkbook.Worksheets("工作表名")
  '从工作簿中读取数据
    .Range("A10").Formula = wb.Worksheets("源工作表名").Range("A10").Formula
    .Range("A11").Formula = wb.Worksheets("源工作表名").Range("A20").Formula
    .Range("A12").Formula = wb.Worksheets("源工作表名").Range("A30").Formula
    .Range("A13").Formula = wb.Worksheets("源工作表名").Range("A40").Formula
  End With
  wb.Close False '关闭打开的源数据工作簿且不保存任何变化
  Set wb = Nothing '释放内存
  Application.ScreenUpdating = True
End Sub
示例说明：在运行程序时，打开所要获取数据的工作簿，当取得数据后再关闭该工作簿。将屏幕更新属性值设置为False，将看不出源数据工作簿是否被打开过。本程序代码中，“C:/文件夹名/文件.xls”、"源工作表名"代表工作簿所在的文件夹和工作簿文件名