Thursday 19 November 2015

Few Excel Functions - UFT

Create New Excel file
Function uf_XLS_CreateNewFile(folderPath,fileName)
        Dim rc, ExcelObj, objWorkbook
       
       Set ExcelObj = CreateObject("Excel.Application")
       Set objWorkbook = ExcelObj.Workbooks.Add
       objWorkbook.Title = fileName
       objWorkbook.Subject = fileName
       objWorkbook.SaveAs folderPath &  fileName
       objWorkbook.Close
       ExcelObj.Application.Quit
       Set ExcelObj = Nothing

       If Err.Number <> 0 Then rc = micFail Else rc = micPass
        uf_XLS_CreateNewFile = rc
End Function

Get Specific Column Value:
Function uf_XLS_GetSpecificColumnValue(sExcelPath, sSheetName,sSearchCriteria , sField)
     Dim objExcel
    Dim objWorkbook
    Dim sColumnName
    Dim iKeywordRow
    Dim iFeildColumn
    Dim sValue
    Dim arrSearchCriteria

    arrSearchCriteria = Split(sSearchCriteria,"=")
    sKeywordField = arrSearchCriteria(0)
    sKeyword = arrSearchCriteria(1)
   
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = False
    Set objWorkbook = objExcel.Workbooks.Open(Trim(sExcelPath))
    objExcel.Sheets(Trim(sSheetName)).Select

    iColumnNumber = objExcel.Cells.Find(Trim(sKeywordField)).Column
    sColumnName = uf_XLS_ConvertColNoToColName(iColumnNumber)
   
    iKeywordRow = objExcel.Range(sColumnName & ":" & sColumnName).Find(Trim(sKeyword)).Row
    If sField = "" Then
        iFeildColumn = objExcel.Cells.Find(Trim(sKeyword)).Column + 1
    Else
         iFeildColumn = objExcel.Cells.Find(Trim(sField)).Column
    End If
    sValue = Trim(objExcel.Cells(iKeywordRow, iFeildColumn))
   
    objWorkbook.close
    objExcel.Quit
    Set objWorkbook = Nothing
    Set objExcel=Nothing
   
    uf_XLS_GetSpecificColumnValue = sValue
End Function   

Read Data from ADODB connection:
Function uf_XLS_ExecuteSQLQuery(sExcelPath,sProvider, sSQL)
  
        Dim oConn, objRecordSet, sQuery
        Dim intFieldIndex
       
        Set oConn= CreateObject("ADODB.Connection")

        If UCase(sProvider) ="ACE" Then
                oConn.Open  "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sExcelPath & ";Extended Properties=""Excel 12.0;IMAX=1;HDR=Yes;"";"
            'oConn.Open  "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sExcelPath & ";Extended Properties=""Excel 12.0 Xml;IMAX=1;HDR=Yes"";"
        ElseIf UCase(sProvider) = "JET" Then
             oConn.Open  "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sExcelPath & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        End If
       
        Set objRecordSet = oConn.Execute(sSQL)
       
        Set uf_XLS_ExecuteSQLQuery = objRecordSet
       
End Function

Update excel column value:
Function uf_XLS_UpdateMultipleColumnsValue(sExcelPath, sSheetName,sSearchCriteria , sFieldValueList)

     Dim objExcel
    Dim objWorkbook
    Dim sColumnName
    Dim iKeywordRow
    Dim iFeildColumn
    Dim arrSearchCriteria

    arrSearchCriteria = Split(sSearchCriteria,"=")
    sKeywordField = arrSearchCriteria(0)
    sKeyword = arrSearchCriteria(1)

    arrFieldValueList = Split(sFieldValueList,"#")
   
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = False
    Set objWorkbook = objExcel.Workbooks.Open(Trim(sExcelPath))
    objExcel.Sheets(Trim(sSheetName)).Select

    iColumnNumber = objExcel.Cells.Find(Trim(sKeywordField)).Column
    sColumnName = uf_XLS_ConvertColNoToColName(iColumnNumber)
   
    iKeywordRow = objExcel.Range(sColumnName & ":" & sColumnName).Find(Trim(sKeyword)).Row

    For iLoop = 0 to Ubound(arrFieldValueList)
        arrFieldValue = Split(arrFieldValueList(iLoop),"=")
        iFeildColumn = objExcel.Cells.Find(Trim(arrFieldValue(0))).Column
        objExcel.Cells(iKeywordRow, iFeildColumn) = Trim(arrFieldValue(1))
    Next

    objExcel.ActiveWorkbook.Save

    If Err.Number <> 0 Then rc = micFail Else rc = micPass
    objWorkbook.close
    objExcel.Application.Quit
    Set objWorkbook = Nothing
    Set objExcel=Nothing
   
    uf_XLS_UpdateMultipleColumnsValue = rc
End Function       

1 comment: