Export table from access to excel and transpose layout

[jaabaar]

I am trying to export a table from access to excel and transpose layout in excel. For example:

Tran Op # Fish Op # Date Start Date end Catch Transfer
1 1 14/05/2011 15/05/2011 Y N
2 2 N Y Y

resuly needed:

Transpose to:
Transfer Op # 1 2
Fishing Op# 1 2
Date Start 14/05/2011 12:33
Date End 14/05/2011 12:33
(BCD) not presented Y Y
obstructed in their duties Y N
Access to communication facilities denied Y Y
catch 10% greater N N

Code I am using:

Function SendToExcel(strQueryName 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
Dim gobjExcel As Excel.Application

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, "qry_OriginalNonComplianceLayout") Then
If CreateExcelObj() Then
'add a workbooks
gobjExcel.Workbooks.Add
'Create a reference to the active sheet
Set objWS = gobjExcel.ActiveSheet
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
objWS.Cells(1, intColCount).Value = fld.Name
intColCount = intColCount + 1
End If
Next fld
'send record set to excel
objWS.Range("A2").CopyFromRecordset rstData, 35000
gobjExcel.Range("A1").Select

'Set AutoFilter
gobjExcel.Selection.AutoFilter
gobjExcel.Visible = True
Else
MsgBox "Excel not Successfully Launched", vbInformation
End If
Else
MsgBox "Too many Records to Send to Excel", vbInformation
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

‘####

Function CreateExcelObj() As Boolean
On Error GoTo CreateExcelObj_Fail
Dim gobjExcel As Excel.Application
'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

‘##############

Function CreateRecordSet(rstData As ADODB.Recordset, rstCount As ADODB.Recordset, _
strTableName As String)
On Error GoTo CreateRecordSet_Fail
'Create recordset that contains count of records in query resuklt
rstCount.Open "Select Count(*) as NumRecords From " & strTableName
'if more than 35000 records in query result, return false
'otherwise, create recordset from query
If rstCount!numrecords > 35000 Then
CreateRecordSet = False
Else
rstData.Open strTableName
CreateRecordSet = True
End If
Exit_CreateRecordSet:
Set rstCount = Nothing
Exit Function
CreateRecordSet_Fail:
MsgBox "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Resume Exit_CreateRecordSet
End Function

‘#####
Problems:
When I run the code :
SendToExcel("TableName")
I get an error message (Error: 91 was generated by database. Object variable or with block variable not set.

I also do not now how to fix and have to transpose . Please help with fixing the code.

 

[SkipVought]

Why not use COPY 'n' .PasteSpecial Paste:=xlPasteAll, Transpose:=True

Skip,

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

 

[jaabaar]

as you can see my code does not work correctly yet it fails I cant see how to fix it and where do I place (.PasteSpecial Paste:=xlPasteAll, Transpose:=True) your help would be greatly appriciated.

 

[SkipVought]

On EXACTLY what statement does your code error?

Skip,

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

 

[SkipVought]

One of the first things I see is that you have, for instance, the Excel Application object, gobjExcel, declared in BOTH CreateExcelObj and SendToExcel.

You do not seem to understand the SCOPE of variables. A variable decalred in a procedure is only available to that procedure. If you have a variable that you want available to ALL the procedures in a module, you must declare them at the top of the module before any procedures are coded.

Please read and understand the VB Help on SCOPE & VISIBILITY.

Skip,

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

 

[SkipVought]

Where do you want the transposted result pasted?

Skip,

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

 

[SkipVought]

once you get your Excel application object correctly declared, this is modified from SendToExcel...

    If CreateExcelObj() Then
        'add a workbooks[b]
        With gobjExcel.Workbooks.Add[/b]
            'Create a reference to the active sheet[b]
            With .Sheets(1)[/b]
                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[b red]
                        .[/b red]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
            
            With .Worksheets.Add(After:=Sheets(.Worksheets.Count))
                .Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
            End With
        End With
    Else
        MsgBox "Excel not Successfully Launched", vbInformation
    End If

Skip,

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

 

[SkipVought]

once you get your Excel application object correctly declared, this is modified from SendToExcel...

    If CreateExcelObj() Then
        'add a workbooks[b]
        With gobjExcel.Workbooks.Add[/b]
            'Create a reference to the active sheet[b]
            With .Sheets(1)[/b]
                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[b]
                        .Cells(1, intColCount).Value = fld.Name[/b]
                        intColCount = intColCount + 1
                    End If
                Next fld
                'send record set to excel[b][red]
        '** If you are going to transpose, then you are limited to 16383 rows of data[/red][/b][b]
                .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("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
            End With
        End With[/b]
    Else
        MsgBox "Excel not Successfully Launched", vbInformation
    End If

Skip,

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

 

[jaabaar]

First of all thank you very much SkipVault.

"One of the first things I see is that you have, for instance, the Excel Application object, gobjExcel, declared in BOTH CreateExcelObj and SendToExcel."

you are right it should be in one place CreateExcelObj "Dim gobjExcel As Excel.Application" and not in send to excel. it just will not see gobjExcel as declared. I just placed it there for testing.

I hope it makes sense.

I will give it a try tomorrow and tell you how I am getting along.

 

[SkipVought]

it should be in one place CreateExcelObj "Dim gobjExcel As Excel.Application" and not in send to excel.

'One place': yes

'CreateExcelObj': [red]NO![/red]

Apparently, you did not bother to inform youself regarding SCOPE & VISIBILITY

You have other similar problems as well.

Fair warning.


Skip,

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

 

[jaabaar]

Thanks I will read and get back to you.

 

[kjv1611]

Although you should be able to find what you need in the help files, here's another online reference for SCOPE and VISIBILITY:

http://www.ozgrid.com/VBA/variable-scope-lifetime.htm

It's pretty straight forward - look at the help file and/or the above reference, and then post back with whether you understand it or not - along with any related questions.

 

[jaabaar]

This “Dim gobjExcel As Excel.Application” I have placed as a module level variable and updated how a table is passed through.

The SendtoExcel function works only once then it fails with the following error message:

Error# 1004 was generated by <database name>
Method ‘Sheets’ of object _Global Failed

On line (and word sheets)

With .Worksheets.Add(After:=Sheets(.Worksheets.Count))
.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True

Updated code as follow:

‘####
Function SendToExcel(strTableUsing 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("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
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

‘###

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

‘##
CREATERECORDSET AS ABOVE NOT CHANGED

Further Help:

How can I add make paste special paste in cell F5 and pace a title in K2.
Is this correct:
With .Worksheets.Add(After:=Sheets(.Worksheets.Count))
.Range("F5").PasteSpecial Paste:=xlPasteAll, Transpose:=True

If so How to add the title to cell K2.

Thanks again for all your help

 

[SkipVought]

               With .Worksheets.Add(After:=Sheets(.Worksheets.Count))
                   .Range("F5").PasteSpecial Paste:=xlPasteAll, Transpose:=True
                   .[K2].value = "TITLE"
'.......

Skip,

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

 

[jaabaar]

Hi SkipVought,

Thank you very much for all your advice very much appriciated. What about the error I am recieving.


Thanks a million

 

[SkipVought]

Error# 1004 was generated by <database name>
Method 'Sheets' of object _Global Failed

On line (and word sheets)

With .Worksheets.Add(After:=Sheets(.Worksheets.Count))
.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True

what does that mean?

1. there is no line that has the text and word sheets

2. the following code you referenced is on TWO lines

Please be clear, concise and complete!

Skip,

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

 

[jaabaar]

Hi

the copde runs once perfectly. once I finish and close excel and re-run the function again I get the following error: and the code stops runing untill I restart the computer. and then it will only run once.

Error# 1004 was generated by <My database name>
Method 'Sheets' of object _Global Failed

this error is produced on line:
With .Worksheets.Add(After:=Sheets(.Worksheets.Count))

I hope that makes sense?

 

[SkipVought]

        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[b]
        'add a sheet in that LAST tab position
            With .Worksheets.Add(After:=.Sheets(.Worksheets.Count))
                .Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
            End With[/b]
        End With

Skip,

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

 

[jaabaar]

Thank you I cant beleave I did not see missing . before sheets.

Your help was very much appriciated. I started playing with formating wow so cool.

 

[SkipVought]

Sorry. I had previously missed including the reference on Sheets.

Skip,

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