excel

'检测文件Function CheckFile(ByVal strFile As String) As BooleanDim FileXls As ObjectSet FileXls = CreateObject("Scripting.FileSystemObject")If IsNull(strFile) Or strFile = "" ThenCheckFile = FalseExit FunctionEnd IfIf FileXls.FileExists(strFile) = False ThenCheckFile = FalseSet FileXls = NothingExit FunctionElseCheckFile = TrueSet FileXls = NothingEnd IfEnd Function'检测工作表Function CheckSheet(ByVal strSheet As String, ByVal strWorkBook As String, xlCheckApp As Excel.Application) As BooleanDim L As IntegerDim CheckWorkBook As Excel.WorkbookIf CheckFile(strWorkBook) And strSheet <> "" And Not IsNull(strSheet) Then For L = 1 To xlCheckApp.Workbooks.CountIf GetPath(xlCheckApp.Workbooks(L).Path) &xlCheckApp.Workbooks(L).Name = strWorkBook ThenSet CheckWorkBook = xlCheckApp.Workbooks(L)Exit ForEnd IfNext LSet CheckWorkBook = xlCheckApp.Workbooks.Open(strWorkBook)For L = 1 To CheckWorkBook.Worksheets.CountIf CheckWorkBook.Worksheets(L).Name = Trim(strSheet) ThenCheckSheet = TrueExit ForEnd IfNext LElseMsgBox "工作表不存在，可能是由文件名或工作表名引起的！"CheckSheet = FalseEnd IfEnd 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.WorksheetIf CheckFile(strWorkBook) ThenxlCreateApp.Workbooks.Open (strWorkBook)If CreateMethod = 1 ThenIf CheckSheet(strSheetName, strWorkBook, xlCreateApp) = False ThenSet xlCreateSheet = xlCreateApp.Worksheets.Add = strSheetNamexlCreateApp.ActiveWorkbook.SaveCreateSheet = TrueSet xlCreateSheet = NothingElse'MsgBox strSheetName & "工作表已存在！"CreateSheet = FalseSet xlCreateSheet = NothingEnd IfElseIf CreateMethod = 2 ThenIf CheckSheet(strSheetName, strWorkBook, xlCreateApp) = True ThenSet xlCreateSheet = xlCreateApp.Worksheets(strSheetName)xlCreateSheet.Cells.SelectxlCreateSheet.Cells.DeletexlCreateApp.ActiveWorkbook.SaveCreateSheet = TrueSet xlCreateSheet = NothingElse'MsgBox strSheetName & "工作表不存在！"CreateSheet = FalseSet xlCreateSheet = NothingEnd IfEnd IfEnd IfEnd Function'删除工作表Function DeleteSheet(ByVal strSheetName As String, ByVal strWorkBook As String, xlDeleteApp As Excel.Application) As BooleanDim i As IntegerDim xlDeleteSheet As Excel.WorksheetIf CheckFile(strWorkBook) ThenIf CheckSheet(strSheetName, strWorkBook, xlDeleteApp) = True ThenxlDeleteApp.Workbooks.Open (strWorkBook)If xlDeleteApp.Worksheets.Count = 1 ThenMsgBox "工作薄不能全部删除，" & strSheetName & "是最后一个工作表！"DeleteSheet = FalseExit FunctionEnd IfxlDeleteApp.Worksheets(strSheetName).DeletexlDeleteApp.ActiveWorkbook.SaveDeleteSheet = TrueElseDeleteSheet = FalseEnd IfEnd IfEnd Function'复制工作表Function CopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As BooleanDim xlSrcBook As Excel.WorkbookDim xlTagBook As Excel.WorkbookDim ExcelSource As Excel.WorksheetDim ExcelTarget As Excel.WorksheetDim Result As BooleanIf CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then Set ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = NothingCopySheet = FalseExit FunctionElseSet xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)If strSrcWorkBook = strTagWorkbook ThenIf strSrcSheetName = strTagSheetName ThenSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = NothingCopySheet = FalseExit FunctionEnd IfSet xlTagBook = xlSrcBookElseSet xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook)End IfSet ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)ExcelSource.SelectExcelSource.Cells.CopyExcelTarget.SelectExcelTarget.PastexlCopyApp.Application.CutCopyMode = xlCopyIf strSrcWorkBook = strTagWorkbook ThenxlTagBook.SavexlSrcBook.SaveElsexlTagBook.SaveEnd IfSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = NothingCopySheet = TrueEnd IfEnd Function'复制工作表Function ExcelCopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As BooleanDim xlSrcBook As Excel.WorkbookDim xlTagBook As Excel.WorkbookDim ExcelSource As Excel.WorksheetDim ExcelTarget As Excel.WorksheetDim Result As BooleanIf CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then Set ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = NothingCopySheet = FalseExit FunctionElseSet xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)If strSrcWorkBook = strTagWorkbook ThenIf strSrcSheetName = strTagSheetName ThenSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = NothingCopySheet = FalseExit FunctionEnd IfSet xlTagBook = xlSrcBookElseSet xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook) End IfSet ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)ExcelSource.SelectExcelSource.Copy beforeExcelTarget.SelectExcelTarget.PastexlCopyApp.Application.CutCopyMode = xlCopyIf strSrcWorkBook = strTagWorkbook ThenxlTagBook.SavexlSrcBook.SaveElsexlTagBook.SaveEnd IfSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = NothingCopySheet = TrueEnd IfEnd Function'关闭Excel应用Function CloseExcelApp(xlApp As Object)On Error Resume NextxlApp.QuitSet xlApp = NothingEnd Function'建立Excel应用Function CreateExcelApp(QuitApp As Boolean) As ObjectOn Error Resume NextDim xlObject As ObjectIf CheckExcel ThenSet xlObject = GetObject(, "Excel.Application")If err.Number <> 0 ThenSet xlObject = NothingSet xlObject = CreateObject("Excel.Application")CreateExcelApp = xlObjectElseIf QuitApp ThenxlObject.QuitSet xlObject = NothingSet xlObject = CreateObject("Excel.Application")End IfCreateExcelApp = xlObjectEnd IfEnd IfEnd Function'检测EXCEL环境Function CheckExcel() As BooleanDim xlCheckApp As ObjectSet xlCheckApp = CreateObject("Excel.Application")If xlCheckApp Is Nothing ThenMsgBox "对不起，系统未检测到EXCEL安装，请重新检查EXCEL是否被正确安装！"CheckExcel = FalsexlCheckApp.QuitSet xlCheckApp = NothingExit FunctionElsexlCheckApp.QuitCheckExcel = TrueSet xlCheckApp = NothingEnd IfEnd FunctionFunction CreateWorkBook(ByVal strWorkBook As String, xlApp As Excel.Application)Dim xlCreateWorkBook As Excel.WorkbookSet xlCreateWorkBook = xlApp.Workbooks.Add xlCreateWorkBook.SaveAs (strWorkBook)End FunctionFunction GetPath(strPath As String) As StringGetPath = IIf(Len(strPath) = 3, strPath, strPath & "\")End Function。