Export MS Access data to MS Excel and insert several blank rows above data

[tranchemontaigne]

I want to export data from MS Access into MS Excel and make the data appear with several rows at the top. The top rows will be filled with business name, date of report generation, report title, column titles, etc.
The problem is that I hve not figured out how to export MS Access data so that it begins to fill the page at row 5.

I've investigated docmd.transferspreadsheet, docmd.outputto, and have not had any luck. Does anyone have a suggestion on how to do this?
My thought was that I coud maybe use a DDEexecute command to insert blank rows above the transferspreadsheet or outputto data dump, then use a DDEPoke to insert static values to label the table and document.I'm not convinced this is the right approach.

Should I be using an ADODB method to force the posting of dumped data to a named range in the MS Excel spreadsheet?
________
Herbalaire Vaporizers

 

[dmonney]

adding rows after dump

Have you considered dumping it into a file and then adding rows into the document? through VBA?

 

[tranchemontaigne]

thanks for the quick reply - it's appreciated. I appreciate your feedback, but am not sure how to do this with VBA.

What would you recommend as the technique to add rows?

I have not figured out how this would be done with DDEexecute. If you were thinking DDEexecute, would you be so kind as to provide a code snippet so I can get the syntax correct?

I look forward to hearing from you.
________
GSX650F

 

[tranchemontaigne]

content is bogus

Here's my working code. It seems to be working for me now, thought it is a bit clunky

fnTEST generates the MS Excel export

Public Function fnTEST()
'////////////////////////////////////////////////////////////////////
'// Function: fnTest
'// XLS Headers Module
'////////////////////////////////////////////////////////////////////
'// Author:
'// Andrew Semenov
'// http://www.zmey.1977.ru/Excel_And_Autofilter.htm
'// Modified:
'// Date Editor Description
'// =============================================================
'// 13 Aug 2008 Chris Taylor Added comments and formatted for
'// improved readability, removed
'// unused variable "n" from function
'//
'////////////////////////////////////////////////////////////////////
'// Description:
'// sets variables and uses them to created heirarchical headers
'// in an MS Access spreadsheet
'//
'////////////////////////////////////////////////////////////////////
'// Variables:
'// Variable Datatype Description
'// =============================================================
'// XL Object
'// WB Workbook -MS Excel Workbook
'// WS Worksheet -MS Excel Worksheet
'// n Long - ? (not used in function)
'// m Long - ? (not used in function)
'// x Long -MS Excel row number for first cell
'// y Long -MS Excel column number for first cell
'// labels variant -Multidimentional array of labels with
'// a sub array for each row of headers
'// palki boolean -indicator used to add table borders
'//
'//////////////////////////////////////////////////////////////////////
'// Requirements:
'// Microsoft Visual Basic for Applications
'// Microsoft Access 9.0 Object Library
'// Microsoft Excel 9.0 Object Library
'// fnTXLOut (MS
'// fnCreate_Heirarchical_Headers (XLS Headers Module)
'// fnDrawXLSBox (XLS Headers Module)
'//////////////////////////////////////////////////////////////////////
'declare variables
Dim XL As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim n As Long, m As Long
Dim x As Long
Dim y As Long
Dim labels As Variant
'create MS Excel file
Set XL = CreateObject("excel.application")

'set number of worksheets in workbook
XL.SheetsInNewWorkbook = 1

'make MS Excel file visible
XL.Visible = True

'add defined number of worksheet pages to workbook
Set WB = XL.Workbooks.Add

Set WS = WB.Worksheets(1)
'=============================================================================
' begin attempt to populate cells with data below heirarchical headers
'=============================================================================
Dim strSQL As String
strSQL = "SELECT "
strSQL = strSQL & "Chr(39) & [2010].[class] AS Class_,"
strSQL = strSQL & "[2010].Description, "
strSQL = strSQL & "[2010].BCHS, "
strSQL = strSQL & "[2010].BDCHS, "
strSQL = strSQL & "[2010].BLS, "
strSQL = strSQL & "[2010].BPHI, "
strSQL = strSQL & "[2010].BPPM, "
strSQL = strSQL & "[2010].BPS, "
strSQL = strSQL & "[2010].Director, "
strSQL = strSQL & "[2010].HSPR, "
strSQL = strSQL & "[2010].[Non-DPHS], "
strSQL = strSQL & "[2010].Other, "
strSQL = strSQL & "[2010].Total, "
strSQL = strSQL & "[2011].BCHS, "
strSQL = strSQL & "[2011].BDCHS, "
strSQL = strSQL & "[2011].BLS, "
strSQL = strSQL & "[2011].BPHI, "
strSQL = strSQL & "[2011].BPPM, "
strSQL = strSQL & "[2011].BPS, "
strSQL = strSQL & "[2011].Director, "
strSQL = strSQL & "[2011].HSPR, "
strSQL = strSQL & "[2011].[Non-DPHS], "
strSQL = strSQL & "[2011].Other, "
strSQL = strSQL & "[2011].Total "
strSQL = strSQL & "FROM "
strSQL = strSQL & "2010 "
strSQL = strSQL & "INNER JOIN 2011 "
strSQL = strSQL & "ON "
strSQL = strSQL & "([2011].Description = [2010].Description) "
strSQL = strSQL & "AND "
strSQL = strSQL & "([2010].Class = [2011].Class)"
strSQL = strSQL & ";"

x = 1
y = 3


Call fnTXLOut(strSQL, WS, x, y)

'=============================================================================
' end attempt to populate cells with data below heirarchical headers
' return to heirarchical headers function
'=============================================================================

'uncomment different labels for sample
'2 floors simple sample (column titles, and super column titles)
'labels = Array( _
Array("a", "b", "c"), _
Array("1", "2"))

'3 floors (column titles, super column titles, and super super column titles)
'labels = Array( _
Array("a", "b", "c"), _
Array("1", "2"), _
Array("aa", "bb", "cc", "dd"))

'3 floors irregular (column titles, s-column titles, and s-s-column titles irregular number of sub categories)
'labels = Array( _
Array( _
Array("a", "b"), _
Array("1", "2"), _
Array("aa", "bb", "cc", "dd")), _
Array(Array("c"), _
Array("c1", "c2", "c3"), _
Array("ca", "cb", "cc", "cd")))
'OIT Direct Services Report
labels = Array( _
Array("DHHS Office of Information Technology Budget - Direct Services"), _
Array("SFY 2010", "SFY 2011"), _
Array("BCHS", "BDCHS", "BLS", "BPHI", "BPPM", "BPS", "Director", "HSPR", "Non-DPHS", "Other", "Total"))

'set first cell to use when pasting labels
'topleft corner of range where values will be posted
x = 3
y = 1

'Call heirarchical headers function
Call fnCreate_Heirarchical_Headers(WS, x, y, m, labels, True)
'format output after MS Excel spreadsheet has been populated
'Outline Headers
With WS.Range("A1:X3")
.HorizontalAlignment = xlHAlignCenter
.Borders.Weight = xlMedium
End With
'autofit columns
With WS.Range("A1:X49")
.Columns.AutoFit
End With

'center class codes
With WS.Range("A4:A49")
.HorizontalAlignment = xlHAlignCenter
End With

'Outline Data
WS.Range("A1:B2").Merge

Call fnDrawXLSBox(WS, "A4:X45")

With WS.Range("A4:X45")
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

Call fnDrawXLSBox(WS, "A46:X48")

With WS.Range("A46:X48")
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

Call fnDrawXLSBox(WS, "A49:X49")

With WS.Range("A49:X49")
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Call fnDrawXLSBox(WS, "B1:B49")
Call fnDrawXLSBox(WS, "C2:M49")

Set XL = Nothing
End Function

Function fnCreate_Heirarchical_Headers(WS As Worksheet, ByRef x As Long, ByRef y As Long, ByRef m As Long, labels As Variant, Optional palki As Boolean = False)
'////////////////////////////////////////////////////////////////////
'// Function: fnCreate_Heirarchical_Headers
'// XLS Headers Module
'////////////////////////////////////////////////////////////////////
'// Author:
'// Andrew Semenov
'// http://www.zmey.1977.ru/Excel_And_Autofilter.htm
'// Modified:
'// Date Editor Description
'// =============================================================
'// 13 Aug 2008 Chris Taylor Added comments and formatted for
'// improved readability, renamed
'// function, removed unused variable
'// "n" from function, replaced
'// LongestWord function call with
'// fnLongest_Word
'// 20 Aug 2008 Chris Taylor Added cell formatting
'//
'////////////////////////////////////////////////////////////////////
'// Description:
'// Creates heirarchal headers in a generated MS Excel spreadsheet
'//
'////////////////////////////////////////////////////////////////////
'// Input:
'// Variable Datatype Description
'// =============================================================
'// WS Object -MS Excel Worksheet
'// byRef x pointer (Integer) -MS Excel row number for
'// first cell
'// ByRef y pointer (Integer) -MS Excel column number for
'// first cell
'// ByRef m pointer (Integer) -reference to column on MS
'// Excel spreadsheet where
'// range should start
'// labels Variant -Multidimentional array of
'// labels for each tier of
'// headers
'// palki Boolean -indicator used to add
'// table borders
'////////////////////////////////////////////////////////////////////
'// Variables:
'// Variable Datatype Description
'// =============================================================
'// xtemp long temp variable - always equal to x
'// i integer index for walking through array
'// j integer index for walking through array
'// k integer index for walking through dum array
'// tc integer number of subscripts in labels(0) array
'// bc integer number of subscripts in labels(1) array
'// newlabels Variant
'// irregularlabels Variant
'// dum Variant array of values from labels(1)
'//
'//////////////////////////////////////////////////////////////////////
'// Requirements:
'// Microsoft Visual Basic for Applications
'// Microsoft Access 9.0 Object Library
'// Microsoft Excel 9.0 Object Library
'//
'//////////////////////////////////////////////////////////////////////
'declare variables
Dim xtemp As Long
Dim i, j As Integer
Dim k As Integer
Dim tc As Integer
Dim bc As Integer
Dim newlabels() As Variant
Dim irregularlabels As Variant
Dim dum As Variant
tc = UBound(labels(0)) - LBound(labels(0))

For i = 0 To tc

If TypeName(labels(0)(i)) = "Variant()" Then
For j = 0 To UBound(labels)
Call fnCreate_Heirarchical_Headers(WS, x, y, m, labels(j), palki)
Next j
Exit Function

Else
If UBound(labels, 1) = 1 Then
If TypeName(labels(1)(0)) = "Variant()" Then
For j = 0 To UBound(labels(1))
'recursive function call
Call fnCreate_Heirarchical_Headers(WS, x, y, m, labels(j), palki)
Next j

With WS
.Range(.Cells(y, x), .Cells(y, x + m - 1)).Merge
.Range(.Cells(y, x), .Cells(y, x + m - 1)).Value = labels(0)(i)
End With
Exit Function
End If

bc = UBound(labels(1)) - LBound(labels(1))

'set worksheet properties
With WS
ReDim dum(UBound(labels(1)))

For k = 0 To UBound(labels(1))
'dum(k) = LongestWord(CStr(labels(1)(k)), " ") original Semenov code
dum(k) = fnLongest_Word(CStr(labels(1)(k)), " ") 'Taylor code
Next k

'merge cells and paste values into merged cells
.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Merge
.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Value = labels(0)(i)

.Range(.Cells(y + 1, x + m), .Cells(y + 1, x + m + (bc + 1) - 1)).Value = dum
.rows(y + 1).AutoFit
.Range(.Cells(y + 1, x + m), .Cells(y + 1, x + m + (bc + 1) - 1)).EntireColumn.AutoFit

.Range(.Cells(y + 1, x + m), .Cells(y + 1, x + m + (bc + 1) - 1)).Value = labels(1)

.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Merge
.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Value = labels(0)(i)

'set border weight
If palki Then
.Range(.Cells(y + 2, x + m), .Cells(y + 2, x + m + (bc + 1) - 1)).Borders(xlEdgeLeft).Weight = xlMedium
.Range(.Cells(y + 2, x + m), .Cells(y + 2, x + m + (bc + 1) - 1)).Borders(xlEdgeRight).Weight = xlMedium
.Range(.Cells(y + 2, x + m), .Cells(y + 2, x + m + (bc + 1) - 1)).Borders(xlInsideVertical).Weight = xlThin
End If

m = m + bc + 1
End With

Else
ReDim newlabels(UBound(labels, 1) - 1)
For j = 1 To UBound(labels, 1)
newlabels(j - 1) = labels(j)
Next j

xtemp = x + m
Call fnCreate_Heirarchical_Headers(WS, x, y + 1, m, newlabels, palki)

With WS
.Range(.Cells(y, xtemp), .Cells(y, x + m - 1)).Merge
.Range(.Cells(y, xtemp), .Cells(y, x + m - 1)).Value = labels(0)(i)
End With
End If
End If
Next i
End Function

Public Function fnLongest_Word(strString As String, strAltValue As String)
'////////////////////////////////////////////////////////////////////
'// Function: fnLongest_Word
'// XLS Headers Module
'////////////////////////////////////////////////////////////////////
'// Author:
'// Chris Taylor
'// http://www.zmey.1977.ru/Excel_And_Autofilter.htm
'//
'////////////////////////////////////////////////////////////////////
'// Description:
'// Function created as a best guess of what Andrew Semenov's
'// longestword function would return. Unfortunately Andrew's
'// code was not posted on his website to support his version of
'// the fnCreate_Heirarchical_Headers function
'//
'////////////////////////////////////////////////////////////////////
'// Variables:
'// Variable Datatype Description
'// =============================================================
'// strString String -string to evaluate
'// strAltValue String -if string to evaluate is null, then
'// this alternate value is substituted
'//
'//////////////////////////////////////////////////////////////////////
'// Requirements:
'// Microsoft Visual Basic for Applications
'// Microsoft Access 9.0 Object Library
'// Microsoft Excel 9.0 Object Library
'//
'//////////////////////////////////////////////////////////////////////
If IsNull(strString) Then
strString = strAltValue
Else
fnLongest_Word = Len(strString)
End If
End Function

Public Function fnDrawXLSBox(WS As Worksheet, strRange As String)
'////////////////////////////////////////////////////////////////////
'// Function: fnDrawXLSBox
'// XLS Headers Module
'////////////////////////////////////////////////////////////////////
'// Author:
'// Chris Taylor
'// Created
'// August 20, 2008
'// Modified:
'// Date Editor Description
'// =============================================================
'//
'//
'////////////////////////////////////////////////////////////////////
'// Description:
'// draws a border around a range of cells in an MS Excel export
'// spreadsheet
'//
'////////////////////////////////////////////////////////////////////
'// Variables:
'// Variable Datatype Description
'// =============================================================
'// WS Worksheet -MS Excel Worksheet
'// strRange String -Cell Range in MS Excel Worksheet
'// strRangeLeft String -left cell of range
'// strRangeRight String -right cell of range
'// intColin Integer -position of colin delimiter in range
'//
'//////////////////////////////////////////////////////////////////////
'// Requirements:
'// Microsoft Visual Basic for Applications
'// Microsoft Access 9.0 Object Library
'// Microsoft Excel 9.0 Object Library
'//
'//////////////////////////////////////////////////////////////////////
On Error GoTo Err_fnDrawXLSBox
Dim strRangeLeft As String
Dim strRangeRight As String
Dim intColin As Integer
intColin = InStr(strRange, ":")
strRangeLeft = (Left(strRange, intColin - 1))
strRangeRight = (Mid(strRange, intColin + 1, 99))
With WS.Range(strRangeLeft & ":" & strRangeRight)
If IsNull(.Cells.Value) = True Then
.Cells.Value = 0
End If

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
Exit_fnDrawXLSBox:
Exit Function

Err_fnDrawXLSBox:
MsgBox Err.Description
Call fnlogerror
Resume Exit_fnDrawXLSBox

End Function

Public Function fnTXLOut(sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet
'////////////////////////////////////////////////////////////////////
'// Function: fnTXLOut
'// ADODB_XLS_Export module
'////////////////////////////////////////////////////////////////////
'// Author:
'// Andrew Semenov
'// http://zmey.1977.ru/Access_To_Excel.htm
'// Modified:
'// Date Editor Description
'// =============================================================
'// 18 Aug 2008 Chris Taylor Added comments, renamed function
'// and formatted for
'// improved readability, removed
'// unused variable "n" from function
'//
'////////////////////////////////////////////////////////////////////
'// Description:
'// sets variables and uses them to created heirarchical headers
'// in an MS Access spreadsheet
'//
'////////////////////////////////////////////////////////////////////
'// Variables:
'// Variable Datatype Description
'// =============================================================
'// sql String -
'// WS Worksheet -MS Excel Worksheet
'// x Long -MS Excel row number for first cell
'// y Long -MS Excel column number for first cell
'// n Long -
'// m Long -
'// Headers Boolean -
'// a Variant - array
'// rs ADODB Recordset -
'// con ADODB.Connection-
'// c() Variant -
'// i Integer -
'// j Integer -
'// k Integer -
'// l Integer
'//
'//////////////////////////////////////////////////////////////////////
'// Requirements:
'// Microsoft Visual Basic for Applications
'// Microsoft Access 9.0 Object Library
'// ActiveX Data Objects Library
'// Microsoft Excel 9.0 Object Library
'//
'//////////////////////////////////////////////////////////////////////
On Error GoTo whoops
Dim a As Variant
Dim rs As New ADODB.Recordset
Dim con As New ADODB.Connection
Dim c() As Variant
Dim i, j, l, k As Integer

'open recordset
'rs.Open sql, "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & CurrentDb.Name & ";", adOpenForwardOnly, adLockOptimistic
Set rs = New ADODB.Recordset
rs.ActiveConnection = CurrentProject.Connection
rs.Open sql

a = rs.GetRows()
'dynamically define array c
ReDim c(UBound(a, 2), UBound(a, 1))
' Here comes matrix transposition
For k = 0 To UBound(a, 1)
For j = 0 To UBound(a, 2)
c(j, k) = a(k, j)
Next j
Next k

n = UBound(a, 2) + 1
m = UBound(a, 1) + 1

WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)) = c
'Here columns headers are put if necessary
If Headers Then
WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)).rows(1).Insert
For j = 0 To m - 1
WS.Cells(y, j + x).Value = rs.Fields(j).Name
Next j
End If
rs.Close
Exit Function
whoops:
Resume Next
End Function

If anyone sees a way to make this better, please let me know, alternately I hope this will server as a reference for others
________
S-10 Blazer

 

[DanBurn]

Have you tried transfering to a blank excel sheet and then linking that sheet to the one you want. Leave the blank file hidden and never use it other than for holding data. then get it to update the main sheet within your vba..