Palo Excel VBA Sample Code (click to expand/contract)
Option Compare Database
Option Explicit
'1. read specification from Access database
'2. read relevant cell from Excel workbook
'3. write value to PALO database
Dim mxlapp As Excel.Application
Dim mxlwbk As Excel.Workbook
Dim mxlwks As Excel.Worksheet
Dim mrsRecordsToProcess As DAO.Recordset
Dim mstrWorkbook As String
Dim mstrPeriod As String
Dim mrsProfilesToProcess As DAO.Recordset
'select workbook
Function Run()
Dim colFilesTemp As New Collection
Dim colFiles As New Collection
Dim intLoopCounter As Integer
Dim mstrWorkbook As Variant
Dim intWorkbookCounter As Integer
Dim intWorkbookTotalCounter As Integer
Dim strRegExpFilter As String
Dim var As Variant
Set mxlapp = CreateObject("Excel.Application")
mxlapp.Visible = Form_frmRun.chkExcelVisible
Set mrsProfilesToProcess = CurrentDb.OpenRecordset("qselActiveProfiles")
mrsProfilesToProcess.MoveLast
mrsProfilesToProcess.MoveFirst
Do
Set colFilesTemp = Nothing
Set colFiles = Nothing
' RecursiveDir colFilesTemp, mrsProfilesToProcess.Fields("strFolder"), mrsProfilesToProcess.Fields("strFileSpec"), True
RecursiveDir colFilesTemp, mrsProfilesToProcess.Fields("strFolder"), "*", True
'reg exp filter
strRegExpFilter = mrsProfilesToProcess.Fields("strRegExpFilter")
For Each var In colFilesTemp
If RegExpFind(CStr(var), strRegExpFilter, 1) <> "" Then
colFiles.Add var
Debug.Print "Passed reg exp check on " & var
Else
Debug.Print "Failed reg exp check on " & var
End If
Next var
For Each mstrWorkbook In colFiles
Debug.Print "The collection for profile " & mrsProfilesToProcess.Fields("lngProfileID") & " contains " & mstrWorkbook
Next mstrWorkbook
intWorkbookTotalCounter = colFiles.Count
intWorkbookCounter = 0
For Each mstrWorkbook In colFiles
intWorkbookCounter = intWorkbookCounter + 1
Call WriteToLog(Now(), 6, mstrWorkbook) 'write to log
Set mxlwbk = mxlapp.Workbooks.Open(Filename:=mstrWorkbook, UpdateLinks:=False)
Debug.Print "Starting processing for " & mstrWorkbook
Call Form_frmRun.WriteToStatus("Starting processing for " & mstrWorkbook & " ...")
Call Form_frmRun.UpdateProgressBar(intWorkbookCounter / intWorkbookTotalCounter)
mstrPeriod = ""
Eval (mrsProfilesToProcess.Fields("strFunctionForInfo"))
If Len(mstrPeriod) > 0 Then
Call ProcessProfile(mrsProfilesToProcess.Fields("lngProfileID"))
End If
Call Form_frmRun.WriteToStatus("Ended processing for " & mstrWorkbook & ".")
mxlwbk.Close SaveChanges:=False
Call WriteToLog(Now(), 5, mstrWorkbook) 'write to log
Next mstrWorkbook
mrsProfilesToProcess.MoveNext
Loop Until mrsProfilesToProcess.EOF
mxlapp.Quit
MsgBox ("Completed")
End Function
Function ProcessProfile(lngProfileID As Long)
Dim rsElement As DAO.Recordset
Dim varExcelCellValue As Variant
Dim strWorksheet As String
Dim strRange As String
Dim strServer As String
Dim strCube As String
Dim strKPI As String
Dim strLocation As String
Dim varReturnValue As Variant
Dim strReturnValue As String
Set mrsRecordsToProcess = CurrentDb.OpenRecordset("select * from qselGetInfo where lngProfileID = " & lngProfileID)
mrsRecordsToProcess.MoveLast
mrsRecordsToProcess.MoveFirst
Do
GetWorksheetBasedOnRange (mrsRecordsToProcess.Fields("strWorksheet"))
strLocation = mrsRecordsToProcess.Fields("strLocation")
strServer = mrsRecordsToProcess.Fields("strServer")
strCube = mrsRecordsToProcess.Fields("strCube")
strRange = mrsRecordsToProcess.Fields("strRange")
strKPI = mrsRecordsToProcess.Fields("strKPI")
mxlwks.Range("IV65536").Formula = strRange
varExcelCellValue = mxlwks.Range("IV65536")
mxlwks.Range("IV65536").Formula = ""
varReturnValue = mxlapp.Run("PALO.SETDATA", varExcelCellValue, True, strServer, strCube, strKPI, mstrPeriod, strLocation): DoEvents
strReturnValue = CStr(varReturnValue)
If Not Left(strReturnValue, 5) = "Error" Then
Call Form_frmRun.WriteToStatus("Wrote " & strReturnValue & " to " & strServer & ", " & strCube & ", " & strKPI & ", " & mstrPeriod & ", " & strLocation)
Debug.Print "Wrote " & strReturnValue & " to " & strServer & ", " & strCube & ", " & strKPI & ", " & mstrPeriod & ", " & strLocation
Else
Call Form_frmRun.WriteToStatus("Error setting " & strReturnValue & " to " & strServer & ", " & strCube & ", " & strKPI & ", " & mstrPeriod & ", " & strLocation)
Debug.Print "Error setting " & strReturnValue & " to " & strServer & ", " & strCube & ", " & strKPI & ", " & mstrPeriod & ", " & strLocation
End If
mrsRecordsToProcess.MoveNext
Loop Until mrsRecordsToProcess.EOF
End Function
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
blnIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If blnIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
Function GetPeriodDetails_001()
' NOTE: this code requires a reference to the
' Microsoft VBScript Regular Expression type library
'
Dim re As New RegExp
Dim ma As Match
Dim intFinYear As Integer
Dim intPeriod As Integer
Dim intPeriodWeek As Integer
Dim rs As DAO.Recordset
Dim strSQL As String
re.Pattern = "F(\d{2}).*P(\d{1,2})W(\d{1,2})" ' uppercase char followed by 2 digits
re.IgnoreCase = False ' case sensitive search
re.Global = False ' find all the occurrences
For Each ma In re.Execute(mstrWorkbook)
intFinYear = ma.SubMatches(0)
intPeriod = ma.SubMatches(1)
intPeriodWeek = ma.SubMatches(2)
Next
strSQL = "SELECT strWeekID FROM tblPeriod WHERE (((tblPeriod.intFinYear)=" & intFinYear & ") AND ((tblPeriod.intPeriodWeek)=" & intPeriodWeek & ") AND ((tblPeriod.intPeriod)=" & intPeriod & "));"
Set rs = CurrentDb.OpenRecordset(strSQL)
If rs.RecordCount = 1 Then
mstrPeriod = rs.Fields(0)
Else
Debug.Print "Could not find in tblPeriod for " & mstrWorkbook
End If
'need this function to produce by looking up intFinYear, (intWeek OR (intPeriodWeek AND intPeriod))
End Function
Function GetPeriodDetails_002()
' NOTE: this code requires a reference to the
' Microsoft VBScript Regular Expression type library
'
Dim re As New RegExp
Dim ma As Match
Dim intFinYear As Integer
Dim intPeriod As Integer
Dim intWeek As Integer
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strCell As String
Dim wks As Worksheet
re.Pattern = "F(\d{2}) - Period (\d{2})" ' uppercase char followed by 2 digits
re.IgnoreCase = False ' case sensitive search
re.Global = False ' find all the occurrences
For Each ma In re.Execute(mxlwbk.Worksheets(1).Range("E9"))
intFinYear = ma.SubMatches(0)
intPeriod = ma.SubMatches(1)
Next ma
strSQL = "SELECT strPeriodID FROM tblPeriod WHERE (tblPeriod.intFinYear=" & intFinYear & ") AND (tblPeriod.intPeriod=" & intPeriod & ");"
Set rs = CurrentDb.OpenRecordset(strSQL)
If rs.RecordCount = 1 Then
mstrPeriod = rs.Fields(0)
Else
Debug.Print "Could not find in tblPeriod for " & mstrWorkbook
End If
End Function
Function GetWorksheetBasedOnRange(strRegularExpression As String)
Dim re As New RegExp
Dim ma As Match
Dim col As MatchCollection
Dim wks As Worksheet
Dim strCell As String
For Each wks In mxlwbk.Worksheets
re.Pattern = strRegularExpression
re.IgnoreCase = False ' case sensitive search
re.Global = False ' find all the occurrences
Set col = re.Execute(wks.Name)
If col.Count = 1 Then
Set mxlwks = wks
End If
Next wks
End Function
