Export Data to Excel & Format cels 2

[TimTDP]

In Access 2000, I need to export data to Excel.
This I can do.

however I would like to conditionally format cells in the Excel work book. for example, if a cell is empty, change the cell's colour to black.

Is this possible?

 

[PHV]

One way is to pull the data from Excel with a QueryTable (MS-Query) preserving the formatting (even conditional).

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[TimTDP]

I am confused!

I want to go to Excel

Can you explain further?

 

[PHV]

Can you explain further?
Instead of exporting from access you may import from excel.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[fldbryan]

Here is an example where I load a template and then write data to the excel spreadsheet

Function MakeSS_PDP()
    ' Declare an object variable to hold the object
    ' reference. Dim as Object causes late binding.
    DoCmd.Hourglass True
    DoCmd.OpenForm "frmWorking"
    DoCmd.RepaintObject acForm, "frmWorking"
    Dim ExcelSheet As Object, XL As Object
    
    Dim DB
    Dim RS
    
    Dim X
    
    X = 0
    
    Set DB = CurrentDb()
    Set RS = DB.OpenRecordset("Select * from qrySelectReqReportOpen WHERE DIVISIONID=3 ORDER BY RECRUITORS, DEPARTMENT, POSITION", dbOpenDynaset, dbReadOnly)
    Set XL = CreateObject("Excel.Application")
    'Set ExcelSheet = CreateObject("Excel.Sheet")
    Set ExcelSheet = XL.Workbooks.Add("C:\templates\PDP.XLT")

    'open up template
    'ExcelSheet.Application.Workbooks.Open "C:\AL.XLT"

    Do Until RS.EOF
        X = X + 1
        'populate excel row
        ExcelSheet.Sheets(1).Cells((X + 1), 1).Value = X
        ExcelSheet.Sheets(1).Cells((X + 1), 2).Value = RS("Req#")
        ExcelSheet.Sheets(1).Cells((X + 1), 3).Value = RS("CognosNo")
        ExcelSheet.Sheets(1).Cells((X + 1), 4).Value = FullDate(RS("Opened"))
        ExcelSheet.Sheets(1).Cells((X + 1), 5).Value = FullDate(RS("Closed"))
        ExcelSheet.Sheets(1).Cells((X + 1), 6).Value = FullDate(RS("TargetHireDate"))
        ExcelSheet.Sheets(1).Cells((X + 1), 7).Value = FullDate(RS("ForecastHireDate"))
        ExcelSheet.Sheets(1).Cells((X + 1), 8).Value = RS("Priority")
        ExcelSheet.Sheets(1).Cells((X + 1), 9).Value = RS("Division")
        ExcelSheet.Sheets(1).Cells((X + 1), 10).Value = RS("Department")
        ExcelSheet.Sheets(1).Cells((X + 1), 11).Value = RS("Position")
        ExcelSheet.Sheets(1).Cells((X + 1), 12).Value = RS("Status")
        ExcelSheet.Sheets(1).Cells((X + 1), 13).Value = FullDate(RS("NewHireDate"))
        ExcelSheet.Sheets(1).Cells((X + 1), 14).Value = RS("Hiring Manager")
        ExcelSheet.Sheets(1).Cells((X + 1), 15).Value = RS("Sourcing")
        ExcelSheet.Sheets(1).Cells((X + 1), 16).Value = RS("InternalTransferName")
        ExcelSheet.Sheets(1).Cells((X + 1), 17).Value = RS("ExternalCandidatename")
        ExcelSheet.Sheets(1).Cells((X + 1), 18).Value = RS("Recruitors")
        ExcelSheet.Sheets(1).Cells((X + 1), 19).Value = RS("Area Leader")
        ExcelSheet.Sheets(1).Cells((X + 1), 20).Value = RS("Variance")
        
        'Move to next record
        RS.MoveNext
    Loop
    RS.Close
    Set RS = DB.OpenRecordset("Select * from qrySelectReqReportNotOpen WHERE DIVISIONID=3 ORDER BY RECRUITORS, DEPARTMENT, POSITION")
        X = 0
        Do Until RS.EOF
        X = X + 1
        'populate excel row
        ExcelSheet.Sheets(2).Cells((X + 1), 1).Value = X
        ExcelSheet.Sheets(2).Cells((X + 1), 2).Value = RS("Req#")
        ExcelSheet.Sheets(2).Cells((X + 1), 3).Value = RS("CognosNo")
        ExcelSheet.Sheets(2).Cells((X + 1), 4).Value = FullDate(RS("Opened"))
        ExcelSheet.Sheets(2).Cells((X + 1), 5).Value = FullDate(RS("Closed"))
        ExcelSheet.Sheets(2).Cells((X + 1), 6).Value = FullDate(RS("TargetHireDate"))
        ExcelSheet.Sheets(2).Cells((X + 1), 7).Value = FullDate(RS("ForecastHireDate"))
        ExcelSheet.Sheets(2).Cells((X + 1), 8).Value = RS("Priority")
        ExcelSheet.Sheets(2).Cells((X + 1), 9).Value = RS("Division")
        ExcelSheet.Sheets(2).Cells((X + 1), 10).Value = RS("Department")
        ExcelSheet.Sheets(2).Cells((X + 1), 11).Value = RS("Position")
        ExcelSheet.Sheets(2).Cells((X + 1), 12).Value = RS("Status")
        ExcelSheet.Sheets(2).Cells((X + 1), 13).Value = FullDate(RS("NewHireDate"))
        ExcelSheet.Sheets(2).Cells((X + 1), 14).Value = RS("Hiring Manager")
        ExcelSheet.Sheets(2).Cells((X + 1), 15).Value = RS("Sourcing")
        ExcelSheet.Sheets(2).Cells((X + 1), 16).Value = RS("InternalTransferName")
        ExcelSheet.Sheets(2).Cells((X + 1), 17).Value = RS("ExternalCandidatename")
        ExcelSheet.Sheets(2).Cells((X + 1), 18).Value = RS("Recruitors")
        ExcelSheet.Sheets(2).Cells((X + 1), 19).Value = RS("Area Leader")
        ExcelSheet.Sheets(2).Cells((X + 1), 20).Value = RS("Variance")
        
        'Move to next record
        RS.MoveNext
    Loop
    
    
    ' Save the sheet to C:\ directory.
    ExcelSheet.Application.DisplayAlerts = False
    ExcelSheet.SaveAs "C:\PDP.XLS"
    ExcelSheet.Application.DisplayAlerts = True
    'ExcelSheet.Application.View
    On Error Resume Next
    ' Close Excel with the Quit method on the Application object.
    ExcelSheet.Application.Quit
    RS.Close
    DB.Close
    ' Release the object variable.
    Set ExcelSheet = Nothing
    Set RS = Nothing
    Set DB = Nothing
    DoCmd.Close acForm, "frmWorking"
    DoCmd.Hourglass False
    MsgBox "PDP created on C:\PDP.XLS"
    X = Shell("excel.exe c:\pdp.xls", vbMaximizedFocus)
End Function

 

[JerryKlmns]

fldbryan

A modification to speed thinks up :

Dim recArray As Variant

recArray = rstData.GetRows

ExcelSheet.Sheets(1).Cells(2, 2).Resize(rstData.RecordCount, rstData.Fields.count).Value = TransposeDim(recArray)

For iCount= 1 to rstData.RecordCount
ExcelSheet.Sheets(1).Cells(iCount+1, 2).Value = iCount 
Next iCount

Function TransposeDim(v As Variant) As Variant
    
    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant
    
    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)
    
    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = v(Y, X)
        Next Y
    Next X
    
    TransposeDim = tempArray

End Function

And a thought:
You could use one query to retrieve data since both have the same structure. I don't know though if that would speed up things. Something like

"SELECT * " & _
"FROM qrySelectReqReportOpen " & _
"WHERE DIVISIONID = 3 " & _
"ORDER BY RECRUITORS, " & _
   "DEPARTMENT, " & _
   "POSITION " & _
"UNION " & _
"SELECT * " & _
"FROM qrySelectReqReportNotOpen " & _
"WHERE DIVISIONID = 3 " & _
"ORDER BY RECRUITORS, " & _
   "DEPARTMENT, " & _
   "POSITION"