Below is code that I am working with that exports a MS Access query to a MS Excel spreadsheet.
Right now the way this code works is it fills the column headings (field names from query) with a color, and it fills in the range of data to Excel with a different color.
Which is awesome..!! I just need the rows to be colored a different way based on a field in the exported query.
So if rst!PlanStatus = "D" then those rows get a certain color, and if rst!PlanStatus = "A" the font in those rows get a certain color...
Any examples or suggestions as to how I can manipulate this code to "highlight" only the rows (in Excel) that have a certain value in the exported query field PlanStatus..??
Thanks in advance.!!
jcw5107
Public Sub P_SendDataToExcel()
On Error GoTo ErrTrap
Dim QryName As String, Cnt As Long
Dim Qst As String
Dim Rw1 As Long, CL1 As Long
Dim FieldCount As Long, TotRec As Long
Dim strMessage As String
Dim exp As Excel.Application
Dim ws As Excel.Worksheet
Dim rg As Excel.Range
Dim db As DAO.Database
Dim rst As DAO.Recordset
strMessage = "Data Will Get Exported To Excel Workbook " & _
DestnFileName & vbCrLf & "(Active Sheet Will " & _
"Get Renamed As Per Exported Query)" & _
vbCrLf & "Full Path - " & DestnFilePath & _
vbCrLf & vbCrLf & "Shall We Continue?"
If Not Confirm(strMessage) Then
GoTo ExitPoint
End If
QryName = Me.SF_Sub.Form.RecordSource
If Len(QryName) > 0 Then
Else
DisplayMessage "No Data To Export"
GoTo ExitPoint
End If
Set db = DBEngine(0)(0)
' Set exp object to already open Excel application
' (Destn Excel File Opened In Web Browser Control
Set exp = GetObject(, "Excel.Application")
Set ws = exp.ActiveSheet
Rw1 = exp.ActiveCell.Row
CL1 = exp.ActiveCell.Column
' Create a recordset based upon current query
Set rst = db.OpenRecordset(QryName)
FieldCount = rst.Fields.Count
rst.MoveLast
TotRec = rst.RecordCount
rst.MoveFirst
' Clear Any existing contents, highlights or borders
Set rg = ws.Range(ws.Cells(Rw1, CL1), _
ws.Cells(Rw1 + TotRec, CL1 + FieldCount - 1))
rg.Clear
' Populate column headings in excel worksheet
For Cnt = 0 To FieldCount - 1
ws.Cells(Rw1, Cnt + CL1) = rst.Fields(Cnt).Name
Next
' Export recordset data to Excel worksheet
Set rg = ws.Range(ws.Cells(Rw1 + 1, CL1), ws.Cells(Rw1 + 1, CL1))
rg.CopyFromRecordset rst
' Highlight the Column Headings
Set rg = ws.Range(ws.Cells(Rw1, CL1), _
ws.Cells(Rw1, CL1 + FieldCount - 1))
'rg.Interior.ColorIndex = 8
' Highlight the Data Block
rst.MoveLast
Cnt = rst.RecordCount
Set rg = ws.Range(ws.Cells(Rw1 + 1, CL1), _
ws.Cells(Rw1 + TotRec, CL1 + FieldCount - 1))
rg.Interior.ColorIndex = 19
' Provide Border around exported material
Set rg = ws.Range(ws.Cells(Rw1, CL1), _
ws.Cells(Rw1 + TotRec, CL1 + FieldCount - 1))
' rg.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
P_MakeBorders rg
' Name the active sheet as per exported query
' Go to first cell of exported block & save the workbook
ws.Name = DLookup("Fleet", "FleetMstr", "[FleetID] =getglobal('GBLFleetID')") & "WE" & Format(Date + (6 - Weekday(Date)) + 1, "mmddyy")
ws.Cells(Rw1, CL1).Select
exp.ActiveWorkbook.Save
ExitPoint:
On Error Resume Next
Set rg = Nothing
Set ws = Nothing
Set exp = Nothing
rst.Close
Set rst = Nothing
Set db = Nothing
On Error GoTo 0
Exit Sub
ErrTrap:
DisplayMessage Err.Number & " - " & Err.DESCRIPTION
Resume ExitPoint
End Sub
Right now the way this code works is it fills the column headings (field names from query) with a color, and it fills in the range of data to Excel with a different color.
Which is awesome..!! I just need the rows to be colored a different way based on a field in the exported query.
So if rst!PlanStatus = "D" then those rows get a certain color, and if rst!PlanStatus = "A" the font in those rows get a certain color...
Any examples or suggestions as to how I can manipulate this code to "highlight" only the rows (in Excel) that have a certain value in the exported query field PlanStatus..??
Thanks in advance.!!
jcw5107
Public Sub P_SendDataToExcel()
On Error GoTo ErrTrap
Dim QryName As String, Cnt As Long
Dim Qst As String
Dim Rw1 As Long, CL1 As Long
Dim FieldCount As Long, TotRec As Long
Dim strMessage As String
Dim exp As Excel.Application
Dim ws As Excel.Worksheet
Dim rg As Excel.Range
Dim db As DAO.Database
Dim rst As DAO.Recordset
strMessage = "Data Will Get Exported To Excel Workbook " & _
DestnFileName & vbCrLf & "(Active Sheet Will " & _
"Get Renamed As Per Exported Query)" & _
vbCrLf & "Full Path - " & DestnFilePath & _
vbCrLf & vbCrLf & "Shall We Continue?"
If Not Confirm(strMessage) Then
GoTo ExitPoint
End If
QryName = Me.SF_Sub.Form.RecordSource
If Len(QryName) > 0 Then
Else
DisplayMessage "No Data To Export"
GoTo ExitPoint
End If
Set db = DBEngine(0)(0)
' Set exp object to already open Excel application
' (Destn Excel File Opened In Web Browser Control
Set exp = GetObject(, "Excel.Application")
Set ws = exp.ActiveSheet
Rw1 = exp.ActiveCell.Row
CL1 = exp.ActiveCell.Column
' Create a recordset based upon current query
Set rst = db.OpenRecordset(QryName)
FieldCount = rst.Fields.Count
rst.MoveLast
TotRec = rst.RecordCount
rst.MoveFirst
' Clear Any existing contents, highlights or borders
Set rg = ws.Range(ws.Cells(Rw1, CL1), _
ws.Cells(Rw1 + TotRec, CL1 + FieldCount - 1))
rg.Clear
' Populate column headings in excel worksheet
For Cnt = 0 To FieldCount - 1
ws.Cells(Rw1, Cnt + CL1) = rst.Fields(Cnt).Name
Next
' Export recordset data to Excel worksheet
Set rg = ws.Range(ws.Cells(Rw1 + 1, CL1), ws.Cells(Rw1 + 1, CL1))
rg.CopyFromRecordset rst
' Highlight the Column Headings
Set rg = ws.Range(ws.Cells(Rw1, CL1), _
ws.Cells(Rw1, CL1 + FieldCount - 1))
'rg.Interior.ColorIndex = 8
' Highlight the Data Block
rst.MoveLast
Cnt = rst.RecordCount
Set rg = ws.Range(ws.Cells(Rw1 + 1, CL1), _
ws.Cells(Rw1 + TotRec, CL1 + FieldCount - 1))
rg.Interior.ColorIndex = 19
' Provide Border around exported material
Set rg = ws.Range(ws.Cells(Rw1, CL1), _
ws.Cells(Rw1 + TotRec, CL1 + FieldCount - 1))
' rg.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
P_MakeBorders rg
' Name the active sheet as per exported query
' Go to first cell of exported block & save the workbook
ws.Name = DLookup("Fleet", "FleetMstr", "[FleetID] =getglobal('GBLFleetID')") & "WE" & Format(Date + (6 - Weekday(Date)) + 1, "mmddyy")
ws.Cells(Rw1, CL1).Select
exp.ActiveWorkbook.Save
ExitPoint:
On Error Resume Next
Set rg = Nothing
Set ws = Nothing
Set exp = Nothing
rst.Close
Set rst = Nothing
Set db = Nothing
On Error GoTo 0
Exit Sub
ErrTrap:
DisplayMessage Err.Number & " - " & Err.DESCRIPTION
Resume ExitPoint
End Sub