Dim ExcelApp 'As Excel.Application Dim excelSheet 'As Excel.worksheet Dim excelBook 'As Excel.workbook Dim fso 'As scrīpting.FileSystemObject row1=1 mark=0 ' ********************************************************************************************* ' 函数说明:创建一个Excel应用程序ExcelApp,并创建一个新的工作薄Workbook; ' 参数说明:无 ' 调用方法: ' CreateExcel() ' *********************************************************************************************
Function CreateExcel() Dim excelSheet Set ExcelApp = CreateObject("Excel.Application") 'ExcelApp.Workbooks.Add ExcelApp.Visible = True Set CreateExcel = ExcelApp msgbox "111" End Function ' ********************************************************************************************* ' 函数说明:关闭Excel应用程序; ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' 调用方法: ' CloseExcel(ExcelApp) ' ********************************************************************************************* Sub CloseExcel(ExcelApp) Set excelSheet = ExcelApp.ActiveSheet Set excelBook = ExcelApp.ActiveWorkbook Set fso = CreateObject("scrīpting.FileSystemObject") On Error Resume Next fso.CreateFolder "C:\Temp" fso.DeleteFile "C:\Temp\ExcelExamples.xls" excelBook.SaveAs "C:\Temp\ExcelExamples.xls" ExcelApp.Quit Set ExcelApp = Nothing Set fso = Nothing Err = 0 On Error GoTo 0 End Sub ' ********************************************************************************************* ' 函数说明:保存工作薄; ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; ' (3)path:保存的路径; ' 返回结果: ' (1)保存成功,返回字符串:OK ' (2)保存失败,返回字符串:Bad Worksheet Identifier ' 调用方法: ' ret = SaveWorkbook(ExcelApp, "Book1", "D:\Example1.xls") ' ********************************************************************************************* Function SaveWorkbook(ExcelApp, workbookIdentifier, path) 'As String Dim workbook On Error Resume Next '启用错误处理程序 Set workbook = ExcelApp.Workbooks(workbookIdentifier) On Error GoTo 0 '禁用错误处理程序 If Not workbook Is Nothing Then If path = "" Or path = workbook.FullName Or path = workbook.Name Then workbook.Save Else Set fso = CreateObject("scrīpting.FileSystemObject") '判断路径中是否已添加扩展名.xls If InStr(path, ".") = 0 Then path = path & ".xls" End If '删除路径下现有同名的文件 On Error Resume Next fso.DeleteFile path Set fso = Nothing Err = 0 On Error GoTo 0 workbook.SaveAs path End If SaveWorkbook = "OK" Else SaveWorkbook = "Bad Workbook Identifier" End If End Function ' ********************************************************************************************* ' 函数说明:设置工作表excelSheet单元格的值 ' 参数说明: ' (1)excelSheet:工作表名称; ' (2)row:列的序号,第一列为1; ' (3)column:行的序号,第一行为1; ' (4)value:单元格要设置的值; ' 返回结果: ' 无返回值 ' 调用方法: ' SetCellValue excelSheet1, 1, 2, "test" ' ********************************************************************************************* Sub SetCellValue(excelSheet, row, column, value) On Error Resume Next excelSheet.Cells(row, column) = value On Error GoTo 0 End Sub 'The GetCellValue returns the cell's value according to its row column and sheet 'excelSheet - the Excel Sheet in which the cell exists 'row - the cell's row 'column - the cell's column 'return 0 if the cell could not be found ' ********************************************************************************************* ' 函数说明:获取工作表excelSheet单元格的值 ' 参数说明: ' (1)excelSheet:工作表名称; ' (2)row:列的序号; ' (3)column:行的序号; ' 返回结果: ' (1)单元格存在,返回单元格值; ' (2)单元格不存在,返回0; ' 调用方法: ' set CellValue = GetCellValue(excelSheet, 1, 2) ' ********************************************************************************************* Function GetCellValue(excelSheet, row, column) value = 0 Err = 0 On Error Resume Next tempValue = excelSheet.Cells(row, column) If Err = 0 Then value = tempValue Err = 0 End If On Error GoTo 0 GetCellValue = value End Function ' ********************************************************************************************* ' 函数说明:获取并返回工作表对象 ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)sheetIdentifier:属于ExcelApp的工作表名称; ' 返回结果: ' (1)成功:工作表对象Excel.worksheet ' (1)失败:Nothing ' 调用方法: ' Set excelSheet1 = GetSheet(ExcelApp, "Sheet Name") ' ********************************************************************************************* Function GetSheet(ExcelApp, sheetIdentifier) On Error Resume Next Set GetSheet = ExcelApp.Worksheets.Item(sheetIdentifier) On Error GoTo 0 End Function ' ********************************************************************************************* ' 函数说明:添加一张新的工作表 ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; ' (2)sheetName:要插入的工作表名称; ' 返回结果: ' (1)成功:工作表对象worksheet ' (1)失败:Nothing ' 调用方法: ' InsertNewWorksheet(ExcelApp, workbookIdentifier, "new sheet") ' ********************************************************************************************* Function InsertNewWorksheet(ExcelApp, workbookIdentifier, sheetName) Dim workbook 'As Excel.workbook Dim worksheet 'As Excel.worksheet '如果指定的工作薄不存在,将在当前激活状态的工作表中添加工作表 If workbookIdentifier = "" Then Set workbook = ExcelApp.ActiveWorkbook Else On Error Resume Next Err = 0 Set workbook = ExcelApp.Workbooks(workbookIdentifier) If Err <> 0 Then Set InsertNewWorksheet = Nothing Err = 0 Exit Function End If On Error GoTo 0 End If sheetCount = workbook.Sheets.Count '获取工作薄中工作表的数量 workbook.Sheets.Add , sheetCount '添加工作表 Set worksheet = workbook.Sheets(sheetCount + 1) '初始化worksheet为新添加的工作表对象 '设置新添加的工作表名称 If sheetName <> "" Then worksheet.Name = sheetName End If Set InsertNewWorksheet = worksheet End Function ' ********************************************************************************************* ' 函数说明:修改工作表的名称; ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; ' (3)worksheetIdentifier:属于workbookIdentifier工作薄的工作表名称; ' (4)sheetName:修改后的工作表名称; ' 返回结果: ' (1)修改成功,返回字符串:OK ' (2)修改失败,返回字符串:Bad Worksheet Identifier ' 调用方法: ' set ret = RenameWorksheet(ExcelApp, "Book1", "Sheet1", "Sheet Name") ' ********************************************************************************************* Function RenameWorksheet(ExcelApp, workbookIdentifier, worksheetIdentifier, sheetName) Dim workbook Dim worksheet On Error Resume Next Err = 0 Set workbook = ExcelApp.Workbooks(workbookIdentifier) If Err <> 0 Then RenameWorksheet = "Bad Workbook Identifier" Err = 0 Exit Function End If Set worksheet = workbook.Sheets(worksheetIdentifier) If Err <> 0 Then RenameWorksheet = "Bad Worksheet Identifier" Err = 0 Exit Function End If worksheet.Name = sheetName RenameWorksheet = "OK" End Function ' ********************************************************************************************* ' 函数说明:删除工作表; ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; ' (3)worksheetIdentifier:属于workbookIdentifier工作薄的工作表名称; ' 返回结果: ' (1)删除成功,返回字符串:OK ' (2)删除失败,返回字符串:Bad Worksheet Identifier ' 调用方法: ' set ret = RemoveWorksheet(ExcelApp, "Book1", "Sheet1") ' ********************************************************************************************* Function RemoveWorksheet(ExcelApp, workbookIdentifier, worksheetIdentifier) Dim workbook 'As Excel.workbook Dim worksheet 'As Excel.worksheet On Error Resume Next Err = 0 Set workbook = ExcelApp.Workbooks(workbookIdentifier) If Err <> 0 Then RemoveWorksheet = "Bad Workbook Identifier" Exit Function End If Set worksheet = workbook.Sheets(worksheetIdentifier) If Err <> 0 Then RemoveWorksheet = "Bad Worksheet Identifier" Exit Function End If worksheet.Delete RemoveWorksheet = "OK" End Function ' ********************************************************************************************* ' 函数说明:添加新的工作薄 ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' 返回结果: ' (1)成功:工作表对象NewWorkbook ' (1)失败:Nothing ' 调用方法: ' set NewWorkbook = CreateNewWorkbook(ExcelApp) ' ********************************************************************************************* Function CreateNewWorkbook(ExcelApp) Set NewWorkbook = ExcelApp.Workbooks.Add() Set CreateNewWorkbook = NewWorkbook End Function ' ********************************************************************************************* ' 函数说明:打开工作薄 ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)path:要打开的工作薄路径; ' 返回结果: ' (1)成功:工作表对象NewWorkbook ' (1)失败:Nothing ' 调用方法: ' set NewWorkbook = CreateNewWorkbook(ExcelApp) ' ********************************************************************************************* Function OpenWorkbook(ExcelApp, path) On Error Resume Next Set NewWorkbook = ExcelApp.Workbooks.Open(path) Set ōpenWorkbook = NewWorkbook msgbox "222" On Error GoTo 0 End Function ' ********************************************************************************************* ' 函数说明:将工作薄设置为当前工作状态 ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)workbookIdentifier:要设置为当前工作状态的工作薄名称; ' 返回结果:无返回值; ' 调用方法: ' ActivateWorkbook(ExcelApp, workbook1) ' ********************************************************************************************* Sub ActivateWorkbook(ExcelApp, workbookIdentifier) On Error Resume Next ExcelApp.Workbooks(workbookIdentifier).Activate On Error GoTo 0 End Sub ' ********************************************************************************************* ' 函数说明:关闭Excel工作薄; ' 参数说明: ' (1)ExcelApp:Excel应用程序名称; ' (2)workbookIdentifier: ' 调用方法: ' CloseWorkbook(ExcelApp, workbookIdentifier) ' ********************************************************************************************* Sub CloseWorkbook(ExcelApp, workbookIdentifier) On Error Resume Next ExcelApp.Workbooks(workbookIdentifier).Close On Error GoTo 0 End Sub ' ********************************************************************************************* ' 函数说明:判断两个工作表对应单元格内容是否相等 ' 参数说明: ' (1)sheet1:工作表1的名称; ' (2)sheet2:工作表2的名称; ' (3)startColumn:开始比较的行序号; ' (4)numberOfColumns:要比较的行数; ' (5)startRow:开始比较的列序号; ' (6)numberOfRows:要比较的列数; ' (7)trimed:是否先除去字符串开始的空格和尾部空格后再进行比较,true或flase; ' 返回结果: ' (1)两工作表对应单元格内容相等:true ' (2)两工作表对应单元格内容不相等:flase ' 调用方法: ' ret = CompareSheets(excelSheet1, excelSheet2, 1, 10, 1, 10, False) ' ********************************************************************************************* Function CompareSheets(sheet1, sheet2, startColumn, numberOfColumns, startRow, numberOfRows, trimed) Dim returnVal 'As Boolean returnVal = True '判断两个工作表是否都存在,任何一个不存在停止判断,返回flase If sheet1 Is Nothing Or sheet2 Is Nothing Then CompareSheets = False Exit Function End If '循环判断两个工作表单元格的值是否相等 For r = startRow to (startRow + (numberOfRows - 1)) For c = startColumn to (startColumn + (numberOfColumns - 1)) Value1 = sheet1.Cells(r, c) Value2 = sheet2.Cells(r, c) '如果trimed为true,去除单元格内容前面和尾部空格 If trimed Then Value1 = Trim(Value1) Value2 = Trim(Value2) End If '如果单元格内容不一致,函数返回flase If Value1 <> Value2 Then Dim cell 'As Excel.Range '修改sheet2工作表中对应单元格值 sheet2.Cells(r, c) = "Compare conflict - Value was '" & Value2 & "', Expected value is '" & Value1 & "'." '初始化cell为sheet2中r:c单元格对象 Set cell = sheet2.Cells(r, c) ' '将sheet2工作表中对应单元格的颜色设置为红色 cell.Font.Color = vbRed returnVal = False End If Next Next CompareSheets = returnVal End Function Call CreateExcel() Call OpenWorkbook(ExcelApp, "D:\工作文档\vbs脚本\例子2\AutoUI_FunctionTest.xls") set tab1=GetSheet(ExcelApp, 1) set tab2=GetSheet(ExcelApp, 3) 'msgbox tmp For i=1 to 100 For j=1 to 255 tmp=GetCellValue(tab1, i, j) 'msgbox tmp 'MsgBox (Trim(left(ltrim(tmp),4))) If tmp<>"" Then Call SetCellValue(tab2, i, j, tmp) End If Next Next
|