一組有用的操作Excel的函式 (轉)

一組有用的操作Excel的函式 (轉)[@more@]

在用VB做的時候,它本身的報表並不太好使用,因此應用輸出資料,是一個好方法,以下是一組操縱Excel的據,希望能幫助大家.

'Excel VBA控制函式

'Write By WeiHua 2000.10.12

 

'檢測
Function CheckFile(ByVal strFile As String) As Boolean
Dim FileXls As
Set FileXls = CreateObject("Scripting.FileSystemObject")

  If IsNull(strFile) Or strFile = "" Then
  CheckFile = False
 
  Exit Function
  End If

  If FileXls.FileExists(strFile) = False Then
 
  CheckFile = False
  Set FileXls = Nothing
  Exit Function
  Else
 
  CheckFile = True
  Set FileXls = Nothing
  End If
 
 
End Function
'檢測工作表
Function CheckSheet(ByVal strSheet As String, ByVal strWorkBook As String, xlCheckApp As Excel.Application) As Boolean
Dim L As Integer
Dim CheckWorkBook As Excel.Workbook

If CheckFile(strWorkBook) And strSheet <> "" And Not IsNull(strSheet) Then
  For L = 1 To xlCheckApp.Workbooks.Count
  If GetPath(xlCheckApp.Workbooks(L).Path) & xlCheckApp.Workbooks(L).Name = strWorkBook Then
  Set CheckWorkBook = xlCheckApp.Workbooks(L)
  Exit For
  End If
  Next L
 
 
 
  Set CheckWorkBook = xlCheckApp.Workbooks.Open(strWorkBook)
  For L = 1 To CheckWorkBook.Worksheets.Count
  If CheckWorkBook.Worksheets(L).Name = Trim(strSheet) Then
  CheckSheet = True
  Exit For
  End If
  Next L

Else
  MsgBox "工作表不存在，可能是由檔名或工作表名引起的！"
  CheckSheet = False
End If

End Function

'建立工作表
'CreateMethod:1追加
'CreateMethod:2覆蓋
Function CreateSheet(ByVal strSheetName As String, ByVal strWorkBook As String, ByVal CreateMethod As Integer, xlCreateApp As Excel.Application) As Boolean
Dim xlCreateSheet As Excel.Worksheet

 
  If CheckFile(strWorkBook) Then
 
  xlCreateApp.Workbooks.Open (strWorkBook)
 
 
  If CreateMethod = 1 Then
 
  If CheckSheet(strSheetName, strWorkBook, xlCreateApp) = False Then
 
  Set xlCreateSheet = xlCreateApp.Worksheets.Add
  xlCreateSheet.Name = strSheetName
  xlCreateApp.ActiveWorkbook.Save
 
  CreateSheet = True
  Set xlCreateSheet = Nothing
  Else
  'MsgBox strSheetName & "工作表已存在！"
  CreateSheet = False
  Set xlCreateSheet = Nothing
  End If
 
 
  ElseIf CreateMethod = 2 Then
  If CheckSheet(strSheetName, strWorkBook, xlCreateApp) = True Then
  Set xlCreateSheet = xlCreateApp.Worksheets(strSheetName)
  xlCreateSheet.Cells.
  xlCreateSheet.Cells.Delete
  xlCreateApp.ActiveWorkbook.Save
  CreateSheet = True
  Set xlCreateSheet = Nothing
  Else
  'MsgBox strSheetName & "工作表不存在！"
  CreateSheet = False
  Set xlCreateSheet = Nothing
  End If
 
  End If
 
  End If
 

End Function
'刪除工作表
Function DeleteSheet(ByVal strSheetName As String, ByVal strWorkBook As String, xlDeleteApp As Excel.Application) As Boolean
Dim i As Integer
Dim xlDeleteSheet As Excel.Worksheet
 
  If CheckFile(strWorkBook) Then
 
  If CheckSheet(strSheetName, strWorkBook, xlDeleteApp) = True Then
 
  xlDeleteApp.Workbooks.Open (strWorkBook)
 
  If xlDeleteApp.Worksheets.Count = 1 Then
  MsgBox "工作薄不能全部刪除，" & strSheetName & "是最後一個工作表！"
  DeleteSheet = False
  Exit Function
  End If
 
  xlDeleteApp.Worksheets(strSheetName).Delete

  xlDeleteApp.ActiveWorkbook.Save
  DeleteSheet = True
  Else
  DeleteSheet = False
  End If
 
  End If
 

End Function

'複製工作表
Function CopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As Boolean
Dim xlSrcBook As Excel.Workbook
Dim xlTagBook As Excel.Workbook
Dim Excel As Excel.Worksheet
Dim ExcelTarget As Excel.Worksheet
Dim Result As Boolean

If CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
  CopySheet = False
  Exit Function
Else

  Set xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)
 
  If strSrcWorkBook = strTagWorkbook Then
  If strSrcSheetName = strTagSheetName Then
  Set ExcelSource = Nothing
  Set ExcelTarget = Nothing
  Set xlSrcBook = Nothing
  Set xlTagBook = Nothing
  CopySheet = False
  Exit Function
  End If
 
  Set xlTagBook = xlSrcBook
  Else
  Set xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook)
  End If
 
 
 
  Set ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)
  Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)

  ExcelSource.Select
  ExcelSource.Cells.Copy
  ExcelTarget.Select
  ExcelTarget.Paste
  xlCopyApp.Application.CutCopyMode = xlCopy
 
  If strSrcWorkBook = strTagWorkbook Then
  xlTagBook.Save
  xlSrcBook.Save
  Else
  xlTagBook.Save
  End If
 
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
  CopySheet = True
End If
End Function
'複製工作表
Function ExcelCopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As Boolean
Dim xlSrcBook As Excel.Workbook
Dim xlTagBook As Excel.Workbook
Dim ExcelSource As Excel.Worksheet
Dim ExcelTarget As Excel.Worksheet
Dim Result As Boolean

If CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
  CopySheet = False
  Exit Function
Else

  Set xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)
 
  If strSrcWorkBook = strTagWorkbook Then
  If strSrcSheetName = strTagSheetName Then
  Set ExcelSource = Nothing
  Set ExcelTarget = Nothing
  Set xlSrcBook = Nothing
  Set xlTagBook = Nothing
  CopySheet = False
  Exit Function
  End If
 
  Set xlTagBook = xlSrcBook
  Else
  Set xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook)
  End If
 
 
 
  Set ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)
  Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)

  ExcelSource.Select
  ExcelSource.Copy before
  ExcelTarget.Select
  ExcelTarget.Paste
  xlCopyApp.Application.CutCopyMode = xlCopy
 
  If strSrcWorkBook = strTagWorkbook Then
  xlTagBook.Save
  xlSrcBook.Save
  Else
  xlTagBook.Save
  End If
 
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
  CopySheet = True
End If
End Function

'關閉Excel應用
Function CloseExcelApp(xlApp As Object)
On Error Resume Next
xlApp.Quit
Set xlApp = Nothing
End Function

'建立Excel應用
Function CreateExcelApp(QuitApp As Boolean) As Object
On Error Resume Next
Dim xlObject As Object
If CheckExcel Then

Set xlObject = GetObject(, "Excel.Application")
If err.Number <> 0 Then
  Set xlObject = Nothing
  Set xlObject = CreateObject("Excel.Application")
  CreateExcelApp = xlObject
Else
  If QuitApp Then
  xlObject.Quit
  Set xlObject = Nothing
  Set xlObject = CreateObject("Excel.Application")
  End If
  CreateExcelApp = xlObject
End If

End If

End Function

'檢測EXCEL環境
Function CheckExcel() As Boolean
Dim xlCheckApp As Object
Set xlCheckApp = CreateObject("Excel.Application")

  If xlCheckApp Is Nothing Then
  MsgBox "對不起，未檢測到EXCEL，請重新檢查EXCEL是否被正確安裝！"
  CheckExcel = False
  xlCheckApp.Quit
  Set xlCheckApp = Nothing
  Exit Function
  Else
  xlCheckApp.Quit
  CheckExcel = True
  Set xlCheckApp = Nothing
  End If
End Function

Function CreateWorkBook(ByVal strWorkBook As String, xlApp As Excel.Application)
Dim xlCreateWorkBook As Excel.Workbook

Set xlCreateWorkBook = xlApp.Workbooks.Add

xlCreateWorkBook.SaveAs (strWorkBook)
End Function
Function GetPath(strPath As String) As String
GetPath = IIf(Len(strPath) = 3, strPath, strPath & "")
End Function

 

這上面的函式只不過是一部分,其於的因為專用目的,寫不標準,以後也許會整理出來一份標準的函式庫的!

to:w.hua@ynmail.com">w.hua@ynmail.com