kfschaefer
Programmer
I have a group of code that will update multiple Worksheets within an Excel Workbook and then format the cells according to data within the Excel Cells. from Access Vba
The problem I am having is where to place the 2 function to update the formatting of the cells on the 2 separate worksheets accordingly.
The results I am looking for are as follows:
Populate the wksht(s) with appropriate data, then based on the listbox selection from activation form. The code to update the data within the worksheets works great it is just the formatting that is not recognizing which wksht to update.
See '<<<<<<<<<<<<<<<< within the code and the code for the functions follow
ie.
if gwsht = "Enterprise_ACS" then
Formatting_ACS
Elseif gwksht = "Enterprise_INFSTR" then
Formatting_INFSTR
end if
When I attempt to create an If statement to look at the name of the wksht, the function activates corrrectly, however, it does not like the Set wksht = Worksheet("Enterprise ACS") portion of my function,. And if I keep the calling of the functions outside of the loop then it only updates the 2nd wksht and has no issues with the above mentioned line of code.
Where would you recommend I place this code so that the formatting will happen at the appropriate time and both worksheets are updated and formatted correctly?
Pleae note that If I can eliminate the 2 additoinal functions for formating and replace it with one it would be great See FormatWS. The current problem with this bit of code is the establishing of the worksheet to be formatted or to make each one active at the appropriate time. Any IDEAS would be greatly appreciated.
Thanks,
Karen
The problem I am having is where to place the 2 function to update the formatting of the cells on the 2 separate worksheets accordingly.
The results I am looking for are as follows:
Populate the wksht(s) with appropriate data, then based on the listbox selection from activation form. The code to update the data within the worksheets works great it is just the formatting that is not recognizing which wksht to update.
See '<<<<<<<<<<<<<<<< within the code and the code for the functions follow
ie.
if gwsht = "Enterprise_ACS" then
Formatting_ACS
Elseif gwksht = "Enterprise_INFSTR" then
Formatting_INFSTR
end if
When I attempt to create an If statement to look at the name of the wksht, the function activates corrrectly, however, it does not like the Set wksht = Worksheet("Enterprise ACS") portion of my function,. And if I keep the calling of the functions outside of the loop then it only updates the 2nd wksht and has no issues with the above mentioned line of code.
Where would you recommend I place this code so that the formatting will happen at the appropriate time and both worksheets are updated and formatted correctly?
Pleae note that If I can eliminate the 2 additoinal functions for formating and replace it with one it would be great See FormatWS. The current problem with this bit of code is the establishing of the worksheet to be formatted or to make each one active at the appropriate time. Any IDEAS would be greatly appreciated.
Thanks,
Karen
Code:
Private Sub cmdExportToExcel_Click()
On Error GoTo ProcError
'For Late Binding
' Dim xlApp As Object
'For Early Binding
Dim xlApp As Excel.Application
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim strDataArray() As String
Dim strSQL As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strFolder As String
Dim strFileName As String
Dim i As Integer, j As Integer, intRecordCount As Integer
Dim blnSuccess As Boolean
Dim gWkSht As String
Dim nRow As Integer
Dim bolSwitch As Boolean
StatusMsg Me, ""
strFolder = GetUsersDesktopFolder
strFileName = strFolder & "2010 FTI-ME Ent-DP.xls"
'Determines the column headings for the Training Matrix spreadsheet(s)
strSQL = "SELECT Mid([Ilp Learning Title],1,InStrRev([Ilp Learning Title],'(')-1) AS CourseTitle," & _
" TL_CourseList.[Ilp Learning Cd] AS CourseNumber, TL_CourseList.[Delv Mthd Tot Hrs] AS Duration," & _
" TL_SourceTraining.TrainSource AS CourseSource, TL_CourseList.StandardRequiredDt," & _
" TL_CourseFreq.[Frequency Required]" & _
" FROM TL_SourceTraining INNER JOIN (TL_CourseList LEFT JOIN TL_CourseFreq ON" & _
" TL_CourseList.Frequency = TL_CourseFreq.FreqRecID) ON TL_SourceTraining.SourceRecID = TL_CourseList.SourceRecID" & _
" WHERE (((TL_CourseList.OnXLS) <> 0) And ((TL_CourseList.InActive) = 0))" & _
" GROUP BY Mid([Ilp Learning Title],1,InStrRev([Ilp Learning Title],'(')-1), TL_CourseList.[Ilp Learning Cd]," & _
" TL_CourseList.[Delv Mthd Tot Hrs], TL_SourceTraining.TrainSource, TL_CourseList.StandardRequiredDt," & _
" TL_CourseFreq.[Frequency Required]" & _
" ORDER BY TL_CourseList.StandardRequiredDt, TL_CourseList.[Ilp Learning Cd]"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.RecordCount = 0 Then
MsgBox "There Are No Records to Export for the Courses Selected.", vbInformation, "No Data To Export..."
GoTo ExitProc
Else
rs.MoveLast: rs.MoveFirst 'Required to get an accurate count of records.
intRecordCount = rs.RecordCount
End If
If Dir(strFileName) <> "" Then
Kill (strFileName)
End If
'Sets name of Excel worksheet within the Workbook based on above mentioned Template -
'to be updated based on Unit Chief Name selected form listbox
strSQL1 = "SELECT BEMS AS UCBEMS, WkshtName FROM qryUnitChief WHERE BEMS In (" & MyString & ")"
If rs.RecordCount = 0 Then
Call _
MsgBox("Please make a selection from the list, Click Update and then Click Export to Excel upon completion of the processing of the Update Data.", _
vbCritical, "No Data Found")
Else
Set rs1 = CurrentDb.OpenRecordset(strSQL1, dbOpenSnapshot)
Set xlApp = CreateObject("Excel.Application")
Do Until rs1.EOF
gWkSht = rs1.Fields("WkshtName").value
gBEMS = rs1.Fields("UCBEMS").value
With xlApp
If bolSwitch = False Then
bolSwitch = True
.Workbooks.Add CurrentProject.path & "\2010 FTI-ME Ent-DP.xlt"
End If
.Worksheets(gWkSht).Activate
'Copy course name and course number data, starting at cell F11 = Row 11, Column 6
i = 7
rs.MoveFirst
Do Until rs.EOF
.ActiveSheet.Cells(6, 3).value = Date 'Date Report Ran
.ActiveSheet.Cells(6, i).value = rs!StandardRequiredDt 'Course Required by Date
.ActiveSheet.Cells(7, i).value = rs!Duration 'Course duration
.ActiveSheet.Cells(8, i).value = rs!CourseSource 'Source of Course
.ActiveSheet.Cells(9, i).value = Trim(rs!CourseTitle) 'Course Title
.ActiveSheet.Cells(10, i).value = rs!CourseNumber 'Course ID
i = i + 1
rs.MoveNext
Loop
'Copy detail data, starting at cell "A11"(eleven)
strSQL2 = "SELECT * FROM zTempData Where UCBEMS IN(" & gBEMS & ") ORDER BY EmployeeName"
Set rs2 = CurrentDb.OpenRecordset(strSQL2, dbOpenSnapshot)
.Range("A11").CopyFromRecordset rs2
.Visible = True
blnSuccess = True
'<<<<<<<<<<<<<<<<<<<<<<<<<
FormatWS xlWs
If gWkSht = "Enterprise_ACS" Then
Formatting_ACS '(gWkSht)
ElseIf gWkSht = "Enterprise_INFSTR" Then
Formatting_INFSTR '(gWkSht)
End If
End With
rs1.MoveNext
Loop
'<<<<<<<<<<<<<<<<<<<<<<<<<
xlApp.Workbook.SaveAs strFileName
If blnSuccess = True Then
StatusMsg Me, Mid(strFileName, Len(strFolder) + 1) & " report has been saved to your Desktop folder.", vbBlue
End If
End If
ExitProc:
'Cleanup
If Not rs Is Nothing Then
rs.Close: Set rs = Nothing
End If
If Not rs1 Is Nothing Then
rs1.Close: Set rs1 = Nothing
End If
If Not rs2 Is Nothing Then
rs2.Close: Set rs2 = Nothing
End If
'Set CurrentDb = Nothing
Exit Sub
ProcError:
Select Case Err.Number
Case 70
MsgBox "You Must Close the FTI-ME Ent-DP.xls File" & vbCrLf _
& "Before Attempting to Run This Function.", vbCritical, "Cannot Delete Open File..."
Case 438
GoTo ExitProc
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbCritical, "Error in procedure cmdExportToExcel_Click..."
End Select
Resume ExitProc
Resume
End Sub
Sub FormatWS(ws As Excel.Worksheet)
Dim rng As Range
Dim cl As Range
Dim LastRow As Long
With ws
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set rng = .Range("G11:AJ" & LastRow)
End With
For Each cl In rng
'if current cell is empty or equal to "NR"
If cl.value = "" Or cl.value = "NR" Then
cl.Interior.ColorIndex = xlColorIndexNone
'If course Due Date(F7) > current Date(B5) and current value is Null
If ws.Cells(7, cl.Column) > ws.Cells(7, 2) And cl.value <> "NR" Then
cl.Interior.Color = vbRed
End If
Else
cl.Font.ColorIndex = xlColorIndexAutomatic
cl.Interior.ColorIndex = xlColorIndexNone
End If
If cl.value = "" And cl.value <> "NR" And ws.Cells(7, cl.Column) > ws.Cells(7, 2) Then
cl.Interior.Color = vbYellow
End If
If cl.value > ws.Cells(7, 2) And cl.value <> "NR" Then
cl.Font.Color = vbRed
End If
If cl.value = "" And cl.value <> "NR" And ws.Cells(7, cl.Column) < ws.Cells(7, 2) Then
cl.Interior.Color = vbRed
End If
'if Course Date(current cell value) > Course Due Date(F7) and < Year End date
If cl.value >= ws.Cells(7, cl.Column) And cl.value <= DateSerial(Year(ws.Cells(7, 2)), 13, 0) Then
cl.Interior.Color = vbCyan
End If
'if the last four characters of Employee name (C11) contains "****" ie. John Smith**** then they should be considered New Employee
If Right(ws.Cells(cl.Row, "C"), 4) = "****" And cl.value = "" Then
cl.value = "NH"
cl.Font.Color = vbBlack
cl.Interior.Color = vbGreen
End If
If ws.Cells(9, cl.Column) = "" Then
cl.Interior.ColorIndex = xlColorIndexNone
End If
Next cl
End Sub
Sub Formatting_INFSTR()
Dim ws As Worksheet
Dim rng As Range
Dim cl As Range
Dim LastRow As Long
Dim xlApp As Excel.Application
' frm.Form.txtStatusMsg.Caption = "Processing formatting for spreadsheet"
Set ws = Worksheets("Enterprise_INFSTR")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = ws.Range("G11:AJ" & LastRow)
For Each cl In rng
'if current cell is empty or equal to "NR"
If cl.value = "" Or cl.value = "NR" Then
cl.Interior.ColorIndex = xlColorIndexNone
'If course Due Date(F7) > current Date(B5) and current value is Null
If ws.Cells(7, cl.Column) > ws.Cells(7, 2) And cl.value <> "NR" Then
cl.Interior.Color = vbRed
End If
Else
cl.Font.ColorIndex = xlColorIndexAutomatic
cl.Interior.ColorIndex = xlColorIndexNone
End If
If cl.value = "" And cl.value <> "NR" And ws.Cells(7, cl.Column) > ws.Cells(7, 2) Then
cl.Interior.Color = vbYellow
End If
If cl.value > ws.Cells(7, 2) And cl.value <> "NR" Then
cl.Font.Color = vbRed
End If
If cl.value = "" And cl.value <> "NR" And ws.Cells(7, cl.Column) < ws.Cells(7, 2) Then
cl.Interior.Color = vbRed
End If
'if Course Date(current cell value) > Course Due Date(F7) and < Year End date
If cl.value >= ws.Cells(7, cl.Column) And cl.value <= DateSerial(Year(ws.Cells(7, 2)), 13, 0) Then
cl.Interior.Color = vbCyan
End If
'if the last four characters of Employee name (C11) contains "****" ie. John Smith**** then they should be considered New Employee
If Right(ws.Cells(cl.Row, "C"), 4) = "****" And cl.value = "" Then
cl.value = "NH"
cl.Font.Color = vbBlack
cl.Interior.Color = vbGreen
End If
If ws.Cells(9, cl.Column) = "" Then
cl.Interior.ColorIndex = xlColorIndexNone
End If
Next cl
End Sub
Sub Formatting_ACS()
Dim ws As Worksheet
Dim rng As Range
Dim cl As Range
Dim LastRow As Long
Dim xlApp As Excel.Application
Set ws = Worksheets("Enterprise_ACS")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = ws.Range("G11:AJ" & LastRow)
For Each cl In rng
'if current cell is empty or equal to "NR"
If cl.value = "" Or cl.value = "NR" Then
cl.Interior.ColorIndex = xlColorIndexNone
'If course Due Date(F7) > current Date(B5) and current value is Null
If ws.Cells(7, cl.Column) > ws.Cells(7, 2) And cl.value <> "NR" Then
cl.Interior.Color = vbRed
End If
Else
cl.Font.ColorIndex = xlColorIndexAutomatic
cl.Interior.ColorIndex = xlColorIndexNone
End If
If cl.value = "" And cl.value <> "NR" And ws.Cells(7, cl.Column) > ws.Cells(7, 2) Then
cl.Interior.Color = vbYellow
End If
If cl.value > ws.Cells(7, 2) And cl.value <> "NR" Then
cl.Font.Color = vbRed
End If
If cl.value = "" And cl.value <> "NR" And ws.Cells(7, cl.Column) < ws.Cells(7, 2) Then
cl.Interior.Color = vbRed
End If
'if Course Date(current cell value) > Course Due Date(F7) and < Year End date
If cl.value >= ws.Cells(7, cl.Column) And cl.value <= DateSerial(Year(ws.Cells(7, 2)), 13, 0) Then
cl.Interior.Color = vbCyan
End If
'if the last four characters of Employee name (C11) contains "****" ie. John Smith**** then they should be considered New Employee
If Right(ws.Cells(cl.Row, "C"), 4) = "****" And cl.value = "" Then
cl.value = "NH"
cl.Font.Color = vbBlack
cl.Interior.Color = vbGreen
End If
If ws.Cells(9, cl.Column) = "" Then
cl.Interior.ColorIndex = xlColorIndexNone
End If
Next cl
End Sub