国产一级a片免费看高清,亚洲熟女中文字幕在线视频,黄三级高清在线播放,免费黄色视频在线看

Dim ExcelApp    'As Excel.Application
Dim excelSheet  'As Excel.worksheet
Dim excelBook   'As Excel.workbook
Dim fso         'As scrīpting.FileSystemObject

' *********************************************************************************************
' 函數(shù)說(shuō)明：創(chuàng)建一個(gè)Excel應(yīng)用程序ExcelApp,并創(chuàng)建一個(gè)新的工作薄Workbook;
' 參數(shù)說(shuō)明：無(wú)
' 調(diào)用方法:
'           CreateExcel()
' *********************************************************************************************

Function CreateExcel()
    Dim excelSheet
    Set ExcelApp = CreateObject("Excel.Application")
    ExcelApp.Workbooks.Add 
    ExcelApp.Visible = True
    Set CreateExcel = ExcelApp
End Function
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：關(guān)閉Excel應(yīng)用程序;
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
' 調(diào)用方法:
'           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
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：保存工作薄;
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)workbookIdentifier:屬于ExcelApp的工作薄名稱;
'          (3)path:保存的路徑;
' 返回結(jié)果：
'          (1)保存成功，返回字符串：OK
'          (2)保存失敗，返回字符串：Bad Worksheet Identifier
' 調(diào)用方法:
'           ret = SaveWorkbook(ExcelApp, "Book1", "D:\Example1.xls")
' *********************************************************************************************

Function SaveWorkbook(ExcelApp, workbookIdentifier, path) 'As String
    Dim workbook
    On Error Resume Next  '啟用錯(cuò)誤處理程序
    Set workbook = ExcelApp.Workbooks(workbookIdentifier)
    On Error GoTo 0   '禁用錯(cuò)誤處理程序

    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")
 
            '判斷路徑中是否已添加擴(kuò)展名.xls
            If InStr(path, ".") = 0 Then
                path = path & ".xls"
            End If
 
            '刪除路徑下現(xiàn)有同名的文件
            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
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：設(shè)置工作表excelSheet單元格的值
' 參數(shù)說(shuō)明：
'          (1)excelSheet:工作表名稱;
'          (2)row:列的序號(hào),第一列為1;
'          (3)column:行的序號(hào),第一行為1;
'          (4)value:單元格要設(shè)置的值;
' 返回結(jié)果：
'          無(wú)返回值
' 調(diào)用方法:
'           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
' *********************************************************************************************
' 函數(shù)說(shuō)明：獲取工作表excelSheet單元格的值
' 參數(shù)說(shuō)明：
'          (1)excelSheet:工作表名稱;
'          (2)row:列的序號(hào);
'          (3)column:行的序號(hào);
' 返回結(jié)果：
'          (1)單元格存在,返回單元格值;
'          (2)單元格不存在，返回0;
' 調(diào)用方法:
'           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
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：獲取并返回工作表對(duì)象
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)sheetIdentifier:屬于ExcelApp的工作表名稱;
' 返回結(jié)果：
'          (1)成功：工作表對(duì)象Excel.worksheet
'          (1)失?。篘othing
' 調(diào)用方法:
'           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
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：添加一張新的工作表
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)workbookIdentifier:屬于ExcelApp的工作薄名稱;
'          (2)sheetName:要插入的工作表名稱;
' 返回結(jié)果：
'          (1)成功：工作表對(duì)象worksheet
'          (1)失?。篘othing
' 調(diào)用方法:
'           InsertNewWorksheet(ExcelApp, workbookIdentifier, "new sheet")
' *********************************************************************************************

Function InsertNewWorksheet(ExcelApp, workbookIdentifier, sheetName)
    Dim workbook 'As Excel.workbook
    Dim worksheet 'As Excel.worksheet
 
    '如果指定的工作薄不存在，將在當(dāng)前激活狀態(tài)的工作表中添加工作表
    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  '獲取工作薄中工作表的數(shù)量
    workbook.Sheets.Add , sheetCount '添加工作表
    Set worksheet = workbook.Sheets(sheetCount + 1)  '初始化worksheet為新添加的工作表對(duì)象
 
    '設(shè)置新添加的工作表名稱
    If sheetName <> "" Then
        worksheet.Name = sheetName
    End If
 
    Set InsertNewWorksheet = worksheet
End Function
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：修改工作表的名稱;
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)workbookIdentifier:屬于ExcelApp的工作薄名稱;
'          (3)worksheetIdentifier:屬于workbookIdentifier工作薄的工作表名稱;
'          (4)sheetName:修改后的工作表名稱;
' 返回結(jié)果：
'          (1)修改成功，返回字符串：OK
'          (2)修改失敗，返回字符串：Bad Worksheet Identifier
' 調(diào)用方法:
'           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
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：刪除工作表;
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)workbookIdentifier:屬于ExcelApp的工作薄名稱;
'          (3)worksheetIdentifier:屬于workbookIdentifier工作薄的工作表名稱;
' 返回結(jié)果：
'          (1)刪除成功，返回字符串：OK
'          (2)刪除失敗，返回字符串：Bad Worksheet Identifier
' 調(diào)用方法:
'           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
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：添加新的工作薄
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
' 返回結(jié)果：
'          (1)成功：工作表對(duì)象NewWorkbook
'          (1)失?。篘othing
' 調(diào)用方法:
'          set NewWorkbook = CreateNewWorkbook(ExcelApp)
' *********************************************************************************************

Function CreateNewWorkbook(ExcelApp)
    Set NewWorkbook = ExcelApp.Workbooks.Add()
    Set CreateNewWorkbook = NewWorkbook
End Function
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：打開(kāi)工作薄
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)path:要打開(kāi)的工作薄路徑;
' 返回結(jié)果：
'          (1)成功：工作表對(duì)象NewWorkbook
'          (1)失?。篘othing
' 調(diào)用方法:
'          set NewWorkbook = CreateNewWorkbook(ExcelApp)
' *********************************************************************************************

Function OpenWorkbook(ExcelApp, path)
    On Error Resume Next
    Set NewWorkbook = ExcelApp.Workbooks.Open(path)
    Set ōpenWorkbook = NewWorkbook
    On Error GoTo 0
End Function
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：將工作薄設(shè)置為當(dāng)前工作狀態(tài)
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)workbookIdentifier:要設(shè)置為當(dāng)前工作狀態(tài)的工作薄名稱;
' 返回結(jié)果：無(wú)返回值;
' 調(diào)用方法:
'          ActivateWorkbook(ExcelApp, workbook1)
' *********************************************************************************************

Sub ActivateWorkbook(ExcelApp, workbookIdentifier)
    On Error Resume Next
    ExcelApp.Workbooks(workbookIdentifier).Activate
    On Error GoTo 0
End Sub
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：關(guān)閉Excel工作薄;
' 參數(shù)說(shuō)明：
'          (1)ExcelApp:Excel應(yīng)用程序名稱;
'          (2)workbookIdentifier:
' 調(diào)用方法:
'           CloseWorkbook(ExcelApp, workbookIdentifier)
' *********************************************************************************************

Sub CloseWorkbook(ExcelApp, workbookIdentifier)
    On Error Resume Next
    ExcelApp.Workbooks(workbookIdentifier).Close
    On Error GoTo 0
End Sub
 
' *********************************************************************************************
' 函數(shù)說(shuō)明：判斷兩個(gè)工作表對(duì)應(yīng)單元格內(nèi)容是否相等
' 參數(shù)說(shuō)明：
'          (1)sheet1:工作表1的名稱;
'          (2)sheet2:工作表2的名稱;
'          (3)startColumn:開(kāi)始比較的行序號(hào);
'          (4)numberOfColumns:要比較的行數(shù);
'          (5)startRow:開(kāi)始比較的列序號(hào);
'          (6)numberOfRows:要比較的列數(shù);
'          (7)trimed:是否先除去字符串開(kāi)始的空格和尾部空格后再進(jìn)行比較,true或flase;
' 返回結(jié)果：
'          (1)兩工作表對(duì)應(yīng)單元格內(nèi)容相等：true
'          (2)兩工作表對(duì)應(yīng)單元格內(nèi)容不相等:flase        
' 調(diào)用方法:
'           ret = CompareSheets(excelSheet1, excelSheet2, 1, 10, 1, 10, False)
' *********************************************************************************************

Function CompareSheets(sheet1, sheet2, startColumn, numberOfColumns, startRow, numberOfRows, trimed)
    Dim returnVal 'As Boolean
    returnVal = True
 
    '判斷兩個(gè)工作表是否都存在,任何一個(gè)不存在停止判斷，返回flase
    If sheet1 Is Nothing Or sheet2 Is Nothing Then
        CompareSheets = False
        Exit Function
    End If
 
    '循環(huán)判斷兩個(gè)工作表單元格的值是否相等
    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,去除單元格內(nèi)容前面和尾部空格
            If trimed Then
                Value1 = Trim(Value1)
                Value2 = Trim(Value2)
            End If
 
            '如果單元格內(nèi)容不一致,函數(shù)返回flase
            If Value1 <> Value2 Then
                Dim cell 'As Excel.Range
                '修改sheet2工作表中對(duì)應(yīng)單元格值
                sheet2.Cells(r, c) = "Compare conflict - Value was '" & Value2 & "', Expected value is '" & Value1 & "'." 
                '初始化cell為sheet2中r:c單元格對(duì)象
                Set cell = sheet2.Cells(r, c) '
                '將sheet2工作表中對(duì)應(yīng)單元格的顏色設(shè)置為紅色
                cell.Font.Color = vbRed 
                returnVal = False
            End If
        Next
    Next
    CompareSheets = returnVal
End Function