vbs操作Excel

Dim ExcelApp    'As Excel.Application 
Dim excelSheet 'As Excel.worksheet 
Dim excelBook   'As Excel.workbook 
Dim fso         'As scrīpting.FileSystemObject 
' ********************************************************************************************* 
' 函数说明：创建一个Excel应用程序ExcelApp,并创建一个新的工作薄Workbook; 
' 参数说明：无 
' 调用方法: 
'           CreateExcel() 
' ********************************************************************************************* 
Function CreateExcel() 'As Excel.Application 
    Dim excelSheet 'As Excel.worksheet 
    Set ExcelApp = CreateObject("Excel.Application") 'Create a new excel Object 
    ExcelApp.Workbooks.Add 
    ExcelApp.Visible = True
    Set CreateExcel = ExcelApp 
End Function
' ********************************************************************************************* 
' 函数说明：关闭Excel应用程序; 
' 参数说明： 
'          (1)ExcelApp:Excel应用程序名称; 
' 调用方法: 
'           CloseExcel(ExcelApp) 
' ********************************************************************************************* 
Sub CloseExcel(ExcelApp) 
    Set excelSheet = ExcelApp.ActiveSheet 
    Set excelBook = ExcelApp.ActiveWorkbook 
    Set fso = CreateObject("Scripting.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 'As Excel.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("Scripting.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 'As Excel.workbook 
    Dim worksheet 'As Excel.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) 'As String 
    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 OpenWorkbook = NewWorkbook 
    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
   
   
   
   
' ****************************************** VBS控制Excel的一些常见方法*********************************************************** 
'(一) 使用动态创建的方法 
'首先创建 Excel 对象，使用ComObj: 
Set oExcel = CreateObject( "Excel.Application" ) 
'1) 显示当前窗口： 
oExcel.Visible = True
'2) 更改 Excel 标题栏： 
oExcel.Caption = "应用程序调用 Microsoft Excel"
'3) 添加新工作簿： 
oExcel.WorkBooks.Add 
'4) 打开已存在的工作簿： 
oExcel.WorkBooks.Open( "C:\Excel\Demo.xls" ) 
'5) 设置第2个工作表为活动工作表： 
oExcel.WorkSheets(2).Activate 
或 
oExcel.WorksSheets( "Sheet2" ).Activate 
'6) 给单元格赋值： 
oExcel.Cells(1,4).Value = "第一行第四列"
'7) 设置指定列的宽度（单位：字符个数），以第一列为例： 
oExcel.ActiveSheet.Columns(1).ColumnsWidth = 5 
'8) 设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例： 
oExcel.ActiveSheet.Rows(2).RowHeight = 1/0.035 ' 1厘米 
'9) 在第8行之前插入分页符： 
oExcel.WorkSheets(1).Rows(8).PageBreak = 1 
'10) 在第8列之前删除分页符： 
oExcel.ActiveSheet.Columns(4).PageBreak = 0 
'11) 指定边框线宽度： 
oExcel.ActiveSheet.Range( "B3:D4" ).Borders(2).Weight = 3  '1-左 2-右 3-顶 4-底 5-斜( \ ) 6-斜( / ) 
'12) 清除第一行第四列单元格公式： 
oExcel.ActiveSheet.Cells(1,4).ClearContents 
'13) 设置第一行字体属性： 
oExcel.ActiveSheet.Rows(1).Font.Name = "隶书"
oExcel.ActiveSheet.Rows(1).Font.Color = clBlue 
oExcel.ActiveSheet.Rows(1).Font.Bold = True
oExcel.ActiveSheet.Rows(1).Font.UnderLine = True
'14) 进行页面设置： 
'a.页眉： 
oExcel.ActiveSheet.PageSetup.CenterHeader = "报表演示"
'b.页脚： 
oExcel.ActiveSheet.PageSetup.CenterFooter = "第&P页"
'c.页眉到顶端边距2cm： 
oExcel.ActiveSheet.PageSetup.HeaderMargin = 2/0.035 
'd.页脚到底端边距3cm： 
oExcel.ActiveSheet.PageSetup.HeaderMargin = 3/0.035 
'e.顶边距2cm： 
oExcel.ActiveSheet.PageSetup.TopMargin = 2/0.035 
'f.底边距2cm： 
oExcel.ActiveSheet.PageSetup.BottomMargin = 2/0.035 
'g.左边距2cm： 
oExcel.ActiveSheet.PageSetup.LeftMargin = 2/0.035 
'h.右边距2cm： 
oExcel.ActiveSheet.PageSetup.RightMargin = 2/0.035 
'i.页面水平居中： 
oExcel.ActiveSheet.PageSetup.CenterHorizontally = 2/0.035 
'j.页面垂直居中： 
oExcel.ActiveSheet.PageSetup.CenterVertically = 2/0.035 
'k.打印单元格网线： 
oExcel.ActiveSheet.PageSetup.PrintGridLines = True
'15) 拷贝操作： 
'a.拷贝整个工作表： 
oExcel.ActiveSheet.Used.Range.Copy 
'b.拷贝指定区域： 
oExcel.ActiveSheet.Range( "A1:E2" ).Copy 
'c.从A1位置开始粘贴： 
oExcel.ActiveSheet.Range.( "A1" ).PasteSpecial 
'd.从文件尾部开始粘贴： 
oExcel.ActiveSheet.Range.PasteSpecial 
'16) 插入一行或一列： 
'a. 插入一行 
oExcel.ActiveSheet.Rows(2).Insert 
'b. 插入一列 
oExcel.ActiveSheet.Columns(1).Insert 
'17) 删除一行或一列： 
'a. 删除一行 
oExcel.ActiveSheet.Rows(2).Delete 
'b. 删除一列 
oExcel.ActiveSheet.Columns(1).Delete 
'18) 打印预览工作表： 
oExcel.ActiveSheet.PrintPreview 
'19) 打印输出工作表： 
oExcel.ActiveSheet.PrintOut 
'20) 工作表保存： 
if not oExcel.ActiveWorkBook.Saved then 
   oExcel.ActiveWorkBook.save
'21) 工作表另存为： 
oExcel.ActiveWorkBook.SaveAs( "C:\Excel\Demo1.xls" ) 
'22) 放弃存盘： 
oExcel.ActiveWorkBook.Saved = True
'23) 关闭工作簿： 
oExcel.WorkBooks.Close 
'24) 退出 Excel： 
oExcel.Quit 
'(二) 使用VBS 控制Excle二维图 
'1）选择当第一个工作薄第一个工作表 
set oSheet=oExcel.Workbooks(1).Worksheets(1) 
'2）增加一个二维图 
achart=oSheet.chartobjects.add(100,100,200,200) 
'3）选择二维图的形态 
achart.chart.charttype=4 
'4）给二维图赋值 
set series=achart.chart.seriescollection 
range="sheet1!r2c3:r3c9"
series.add range,true 
'5）加上二维图的标题 
achart.Chart.HasTitle=True
achart.Chart.ChartTitle.Characters.Text=" Excle二维图"
'6）改变二维图的标题字体大小 
achart.Chart.ChartTitle.Font.size=18 
'7）给二维图加下标说明 
achart.Chart.Axes(xlCategory, xlPrimary).HasTitle = True
achart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "下标说明"
'8）给二维图加左标说明 
achart.Chart.Axes(xlValue, xlPrimary).HasTitle = True
achart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "左标说明"
'9）给二维图加右标说明 
achart.Chart.Axes(xlValue, xlSecondary).HasTitle = True
achart.Chart.Axes(xlValue, xlSecondary).AxisTitle.Characters.Text = "右标说明"
'10）改变二维图的显示区大小 
achart.Chart.PlotArea.Left = 5 
achart.Chart.PlotArea.Width = 223 
achart.Chart.PlotArea.Height = 108

如何使用vbs来遍历excel文件：

'获得脚本当前路径 
Set test = createobject("Scripting.FileSystemObject").GetFolder(".")
Set fso = createobject("Scripting.FileSystemObject") 
for Each i in test.Files 
    if LCase(fso.GetExtensionName(i)) = "xlsx" Then
        msgbox i.Name 
    end if 
Next

通过为知笔记发布

posted @ 2012-12-12 13:25 雍朕王朝阅读(906) 评论(0) 编辑收藏举报

会员力量，点亮园子希望

刷新页面返回顶部

雍朕王朝

vbs操作Excel

公告