sending query result(s) to excel and manipulate output

[jaabaar]

Hi

I have a problem trying to perform the following:

1. add a conditional format at end in excel if Collum 1 > than colum 3 then mark red.

2. make heading bold and centered.
3.do not start excel again if you rerun query just add a new sheet if excel already open.

thanks for your help. Code as follow:

Function SendToExcelDataChecks(strTableUsing As String, strTitle As String)
On Error GoTo SendToExcel_Fail

Dim objWS As Excel.Worksheet
Dim rstData As ADODB.Recordset
Dim rstCount As ADODB.Recordset
Dim fld As ADODB.Field
Dim intColCount As Integer
Dim intRowCount As Integer

Set rstData = New ADODB.Recordset
rstData.ActiveConnection = CurrentProject.Connection
Set rstCount = New ADODB.Recordset
rstCount.ActiveConnection = CurrentProject.Connection

'Invoke HourGlass
DoCmd.Hourglass True

'Try to create recordset and create Excel Object
If CreateRecordSet(rstData, rstCount, strTableUsing) Then

If CreateExcelObj() Then
'add a workbooks
With gobjExcel.Workbooks.Add
'Create a reference to the active sheet
With .Sheets(1)
intRowCount = 1
intColCount = 1

'Loop through the fields collection
'make each field name a collumn heading in excel
For Each fld In rstData.Fields
If fld.Type <> adLongVarBinary Then
.Cells(1, intColCount).Value = fld.Name
intColCount = intColCount + 1
End If
Next fld

'send record set to excel
'** If you are going to transpose, then you are limited to 16383 rows of data
.Range("A2").CopyFromRecordset rstData, 16383

.Range("A1").CurrentRegion.Copy
End With
'add a sheet in that LAST tab position
With .Worksheets.Add(After:=.Sheets(.Worksheets.Count))
.Range("B5").PasteSpecial Paste:=xlPasteAll, Transpose:=False
.[C2].Value = strTitle
.[C2].EntireRow.Font.Bold = True
.[C2].EntireRow.Font.Size = 12
.[C2].EntireRow.Font.Name = "Arial"
.[C2].HorizontalAlignment = xlCenter

'stretch all the cells to 30 - this maks the auto work better
'.Cells.EntireColumn.ColumnWidth = 30 'This is for everything if we use cells
.Cells.EntireColumn.ColumnWidth = 30
'autofit the columns
.Cells.EntireColumn.AutoFit


End With
End With
Else
MsgBox "Excel not Successfully Launched", vbInformation
End If
End If

Exit_SendToExcel:
DoCmd.Hourglass False
Set objWS = Nothing
Set rstCount = Nothing
Set rstData = Nothing
Set fld = Nothing


Exit Function

SendToExcel_Fail:

MsgBox "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Resume Exit_SendToExcel


End Function

 

[jaabaar]

Below is excel open object. I want to stop opening excel for every sheet. It needs to check if EXCEL is open do not open another excel just just add the new a new sheet to already open excel.

Function CreateExcelObj() As Boolean
On Error GoTo CreateExcelObj_Fail

'Assume a false return value
CreateExcelObj = False

'Start Excel
Set gobjExcel = New Excel.Application

'if Excel start successfully, return true
gobjExcel.Visible = True
CreateExcelObj = True



Exit_CreateExcelObj:
Exit Function

CreateExcelObj_Fail:

MsgBox "Count not launch Excel.", vbCritical, "Warning"
CreateExcelObj = False
Resume Exit_CreateExcelObj


End Function

 

[jaabaar]

Hi guys

It really is killing me all I want is to adjust code to stop generating a new instance/runing/opening of excel. it just needs to see if excel is open if open send each query to a new sheet leaving open/existing sheets with results there. hope I explained it properly.

 

[Andrzejek]

Try:

Function CreateExcelObj() As Boolean
On Error GoTo CreateExcelObj_Fail

'Assume a false return value
CreateExcelObj = False

'Start Excel[blue]
If Not(gobjExcel Is Nothing) Then[/blue]
    Set gobjExcel = New Excel.Application[blue]
End If[/blue]

'if Excel start successfully, return true
gobjExcel.Visible = True
CreateExcelObj = True
...

Have fun.

---- Andy

 

[jaabaar]

Thanks Andy for your help

Unfortunatly it still starts another excel application. I endup with lots of excel application each containing once sheet which has the result of a query. I Heard it is impossible to just have once excel runing and adding as many sheets as you want.

 

[Andrzejek]

I Heard it is impossible to just have once excel runing and adding as many sheets as you want.

Not true.

Run this code. Assuming new Excel has 3 worksheets (that's why the line of code [tt]If intRun > 3 Then[/tt]), you can set the value of [tt]intS[/tt] to the number of sheets you want. Give it a try:

Dim intS As Integer
Dim intRun As Integer

Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object

intS = 5

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.ActiveSheet

With xlApp
    .Visible = True
    For intRun = 1 To intS
        If intRun > 3 Then[green]
            'Add another Sheet[/green]
            .Sheets.Add
            .Sheets("Sheet" & intRun).Move After:=.Sheets(.Sheets.Count)
        End If
        .Sheets("Sheet" & intRun).Select[green]
        'Here you insert info into the Sheet[/green]
        .Range("A1:A1").Value = Array("'This is sheet " & intRun)
    Next intRun[green]
    'Show first Sheet[/green]
    .Sheets("Sheet1").Select
End With

Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing

I know some people here will look down on .Select, but this is just the code to show you that you can add as many sheets as you want to one Excel running.

Have fun.

---- Andy

 

[jaabaar]

Thanks Andy,

but how can I apply to code below:

Function SendToExcelDataChecks(strTableUsing As String, strTitle As String)
On Error GoTo SendToExcel_Fail

Dim objWS As Excel.Worksheet
Dim rstData As ADODB.Recordset
Dim rstCount As ADODB.Recordset
Dim fld As ADODB.Field
Dim intColCount As Integer
Dim intRowCount As Integer

Set rstData = New ADODB.Recordset
rstData.ActiveConnection = CurrentProject.Connection
Set rstCount = New ADODB.Recordset
rstCount.ActiveConnection = CurrentProject.Connection

'Invoke HourGlass
DoCmd.Hourglass True

'Try to create recordset and create Excel Object
If CreateRecordSet(rstData, rstCount, strTableUsing) Then

If CreateExcelObj() Then
'add a workbooks
With gobjExcel.Workbooks.Add
'Create a reference to the active sheet
With .Sheets(1)
intRowCount = 1
intColCount = 1

'Loop through the fields collection
'make each field name a collumn heading in excel
For Each fld In rstData.Fields
If fld.Type <> adLongVarBinary Then
.Cells(1, intColCount).Value = fld.Name
intColCount = intColCount + 1
End If
Next fld

'send record set to excel
'** If you are going to transpose, then you are limited to 16383 rows of data
.Range("A2").CopyFromRecordset rstData, 16383

.Range("A1").CurrentRegion.Copy
End With
'add a sheet in that LAST tab position
With .Worksheets.Add(After:=.Sheets(.Worksheets.Count))
.Range("B5").PasteSpecial Paste:=xlPasteAll, Transpose:=False
.[C2].Value = strTitle
.[C2].EntireRow.Font.Bold = True
.[C2].EntireRow.Font.Size = 12
.[C2].EntireRow.Font.Name = "Arial"
.[C2].HorizontalAlignment = xlCenter

'stretch all the cells to 30 - this maks the auto work better
'.Cells.EntireColumn.ColumnWidth = 30 'This is for everything if we use cells
.Cells.EntireColumn.ColumnWidth = 30
'autofit the columns
.Cells.EntireColumn.AutoFit


End With
End With
Else
MsgBox "Excel not Successfully Launched", vbInformation
End If
End If

Exit_SendToExcel:
DoCmd.Hourglass False
Set objWS = Nothing
Set rstCount = Nothing
Set rstData = Nothing
Set fld = Nothing


Exit Function

SendToExcel_Fail:

MsgBox "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Resume Exit_SendToExcel


End Function

 

[Andrzejek]

When you step thru your code, which line of your code creates a new Excel?

Have fun.

---- Andy

 

[jaabaar]

Hi

It is the following line:

If CreateExcelObj() Then

To the following fuction:

Function CreateExcelObj() As Boolean
On Error GoTo CreateExcelObj_Fail

'Assume a false return value
CreateExcelObj = False

'Start Excel
If Not (gobjExcel Is Nothing) Then
Set gobjExcel = New Excel.Application
End If

'Set gobjExcel = GetObject(, "Excel.Application")
'If Err = conAppNotRunning Then Set gobjExcel = New Excel.Application

'if Excel start successfully, return true
gobjExcel.Visible = True
CreateExcelObj = True


Exit_CreateExcelObj:
Exit Function

CreateExcelObj_Fail:

MsgBox "Count not launch Excel.", vbCritical, "Warning"
CreateExcelObj = False
Resume Exit_CreateExcelObj

 

[Andrzejek]

So here the blue line of code starts Excel:

[green]'Start Excel[/green]
If Not (gobjExcel Is Nothing) Then[blue]
    Set gobjExcel = New Excel.Application[/blue]
End If

But this line should not run if [tt]gobjExcel[/tt] is alredy set.

Have fun.

---- Andy

 

[jaabaar]

yes thats where most of the problem seem to always go in and starts even if excel is already opoen

 

[Andrzejek]

How about a 'work around':

Option Explicit
Dim blnExcelIsOpen As Boolean
....[green]
'Start Excel[/green]
If Not blnExcelIsOpen Then
    Set gobjExcel = New Excel.Application
    blnExcelIsOpen = True
End If

Have fun.

---- Andy

 

[Andrzejek]

Also, you have some code:
[tt]
...
With gobjExcel.Workbooks.Add
...
[/tt]
I usually add just Sheets to my Workbook, so I have just one Workbook with many Sheets. Maybe that's a (nother) problem.....?

Have fun.

---- Andy

 

[jaabaar]

Hi

It is becoming really embarrassing. I am still stuck unable to fix the problem any chance you could help me change adjusts the code?

Thanks A million

 

[Andrzejek]

OK, here is what I did.
First, I don't know how and where you declared [tt]gobjExcel[/tt], so I did it at the module level.
Second, I don't know where and how often you call the Function [tt]SendToExcelDataChecks[/tt] where you pass strTableUsing and strTitle

But since you create new Excel every time you call [tt]CreateExcelObj[/tt] function, I call it just once, and I placed it before I call [tt]SendToExcelDataChecks[/tt]

I have moved the line of code:
[tt] gobjExcel.Workbooks.Add[/tt]
from [tt]SendToExcelDataChecks[/tt] to [tt]CreateExcelObj[/tt], so when you create Excel, you add a workbook at this time and you do not add any more workbooks.

So in my example (of modifying your code a little), I start my app in Sub Main, call [tt]CreateExcelObj[/tt] function just once where I create a workbook just once, and then call [tt]SendToExcelDataChecks[/tt] 3 times which creates 3 new Sheets in one workbook in one Excel. The first 'default' Sheets: Sheet1, Sheet2, and Sheet3 stay untouched.

Option Explicit[blue]
Dim gobjExcel As Excel.Application[/blue]

Sub Main()
Dim i As Integer

[blue]If CreateExcelObj() Then[/blue]
    For i = 1 To 3
        Call SendToExcelDataChecks("", "")
    Next i
Else
    MsgBox "Excel not Successfully Launched", vbInformation
End If

End Sub

Function SendToExcelDataChecks(strTableUsing As String, strTitle As String)
On Error GoTo SendToExcel_Fail

Dim objWS As Excel.Worksheet
Dim rstData As ADODB.Recordset
Dim rstCount As ADODB.Recordset
Dim fld As ADODB.Field
Dim intColCount As Integer
Dim intRowCount As Integer

Set rstData = New ADODB.Recordset
rstData.ActiveConnection = CurrentProject.Connection
Set rstCount = New ADODB.Recordset
rstCount.ActiveConnection = CurrentProject.Connection
[green]
'Invoke HourGlass
'DoCmd.Hourglass True

'Try to create recordset and create Excel Object
'If CreateRecordSet(rstData, rstCount, strTableUsing) Then
[/green]
With gobjExcel[green]
       'Create a reference to the active sheet[/green]
     With .Sheets(1)
        intRowCount = 1
        intColCount = 1
[green]
        'Loop through the fields collection
        'make each field name a collumn heading in excel['green]
         For Each fld In rstData.Fields
             If fld.Type <> adLongVarBinary Then
                 .Cells(1, intColCount).Value = fld.Name
                 intColCount = intColCount + 1
             End If
         Next fld
        [green]
        'send record set to excel
'** If you are going to transpose, then you are limited to 16383 rows of data[/green]
        .Range("A2").CopyFromRecordset rstData, 16383
        
        .Range("A1").CurrentRegion.Copy
    End With[green]
   'add a sheet in that LAST tab position[/green]
    With .Worksheets.Add(After:=.Sheets(.Worksheets.Count))
        .Range("B5").PasteSpecial Paste:=xlPasteAll, Transpose:=False
        .[C2].Value = "strTitle"
        .[C2].EntireRow.Font.Bold = True
        .[C2].EntireRow.Font.Size = 12
        .[C2].EntireRow.Font.Name = "Arial"
        .[C2].HorizontalAlignment = xlCenter
        [green]
     'stretch all the cells to 30 - this maks the auto work better
     '.Cells.EntireColumn.ColumnWidth = 30   'This is for everything if we use cells[/green]
         .Cells.EntireColumn.ColumnWidth = 30[green]
     'autofit the columns[/green]
        .Cells.EntireColumn.AutoFit
    End With
End With
       
Exit_SendToExcel:[green]
    'DoCmd.Hourglass False[/green]
    Set objWS = Nothing
    Set rstCount = Nothing
    Set rstData = Nothing
    Set fld = Nothing
     
    Exit Function

SendToExcel_Fail:

MsgBox "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Err.Description
Resume Exit_SendToExcel

End Function

Function CreateExcelObj() As Boolean
On Error GoTo CreateExcelObj_Fail
[green]
'Assume a false return value[/green]
CreateExcelObj = False
[green]
'Start Excel[/green][blue]
Set gobjExcel = New Excel.Application
gobjExcel.Workbooks.Add[/blue]
[green]
'Set gobjExcel = GetObject(, "Excel.Application")
'If Err = conAppNotRunning Then Set gobjExcel = New [/green]Excel.Application
[green]
'if Excel start successfully, return true[/green]
gobjExcel.Visible = True
CreateExcelObj = True

Exit_CreateExcelObj:
    Exit Function

CreateExcelObj_Fail:

MsgBox "Count not launch Excel.", vbCritical, "Warning"
CreateExcelObj = False
Resume Exit_CreateExcelObj

End Function

I had to comment out some code to make it work on my side, but I hope you can see what I changed.

Have fun.

---- Andy

 

[jaabaar]

Hi

I have tested and updated above slightly and it works. it runs the query 3 times and place in 3 sheets. When you run the same query again or a new one it should use the same instance of excel as it is already runing if no excel is runing open a fresh one. i.e

Excel open -> open a fresh excel application place result in sheet
excel still open --> run (x) query place result in new sheets. Do not start a new excel application which above still does.

Excel closed: start a new excel application and place result in sheet. as you see we always have one excel runing

I hope I am making sense?

 

[Andrzejek]

You may - as I suggested some time ago - establish a Boolean at the top of your code, something like:
[tt]
Dim blnExcelIsOpen As Boolean
[/tt]
and (re)set it so next time you run your queries you will start new Excel.

The problem with this approach is that user can exit Excel before running more queries.
On the other hand, if you would refer to existing Excel, what if the user starts Excel which has nothing to do with your program? Are you going to insert new sheets into this Excel? Users may not like that...


Have fun.

---- Andy

 

[jaabaar]

Hi Andy,

Thank you for all your time and advice. I have managed to fix and make the code work for me the way I want it too.

Happy New year to you and your family.

Thanks

 

[SkipVought]

A simplified approach, that I use regularly in Excel, is to query the database directly to return data to a sheet. An option can be set to RUN the query each time the workbook is opened, so no VBA code is required.

This will work if you do not need archived workbooks for each of your three runs every day.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}