Hello,
I'm working on an access database (Access 2003) and exporting queries to Excel (Excel 2002). The intention is to get the Access VBA code to format the excel file for me so that all the exports will all look the same, and allow for easy re-importing after other parties (users) have added data to the excel file.
The exporting is working OK, some formatting is working OK as well, however I have 2 major issues that are not working for me, however someone is bound to have come across this before:
As the recordset changes in size each time, I want to be able to automatically change the area(range) that is formatted. Retrieving the size of the recordset is not a problem, but using this result to change the range of cells that need reformatting is.
In addition there are some collumns that I want to hide to enable easier re-importing of the data later. (want to hide the data primary key)
The code that I am using is listed below. I have tried some things (as you can see from the code listed) and I've listed which don't work.
Looking forward to someone's bright idea on this one!
Thanks,
Arjanvb
'-------------------------------------------------------------------------------------------------------------------------
Public Function ExportXLS() As String
' Base methodology copied from: http://july-code.blogspot.com/2007/10/export-data-from-ms-access-to-excel.html
Dim oApp As Excel.Application 'in VBA : Tools : References " MS Excel reference library is required
Dim oWB As Excel.Workbook
Dim i As Integer
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim SQLstring As String
Dim CHANIDnum As Integer
Dim TempCounter As Integer
Dim RowStart As Integer 'to indicate which row Excel starts with putting data in
Dim CollumnStart As Integer 'to indicate which collumn Excel starts with putting data in
Dim NumRows As Integer
Dim TempString As String
Dim NumCollumns As Integer
Dim oSheet As Excel.Worksheet 'from excel example
Dim oRange As Excel.Range 'from excel example
'input channel ID number & other items for conversion to function later
CHANIDnum = 60
SQLstring = "SELECT tbl_QUES.CHANQNUM, tbl_QUES.QUESTEXT, tbl_QUES.ANSWTEXT, tbl_QUES.DATEQUES_SENT, tbl_QUES.QCURR, tbl_QUES.LOGNUMQ, tbl_QUES.QUESID, tbl_QUES.CHANID, tbl_QUES.QANSW "
SQLstring = SQLstring & "FROM tbl_QUES "
SQLstring = SQLstring & "WHERE (((tbl_QUES.DATEQUES_SENT) Is Null) AND ((tbl_QUES.QCURR)=Yes) AND ((tbl_QUES.CHANID)=" & CHANIDnum & ") AND ((tbl_QUES.QANSW)=False)) "
SQLstring = SQLstring & "ORDER BY tbl_QUES.CHANQNUM"
'end input of channel ID
'Create an instance of Excel and add a new blank workbook
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(SQLstring, dbOpenSnapshot)
Set oApp = New Excel.Application
oApp.Visible = False
Set oWB = oApp.Workbooks.Add
'Following deletes excess sheets in workbook to leave only one sheet
If oWB.Sheets.Count > 1 Then
Do While oWB.Sheets.Count > 1
oWB.Sheets(oWB.Sheets.Count).Delete
Loop
End If
'End deletion of extra sheets
'To hide collumn
'oWB.Sheets(1).Collumns("B:B").EntireColumn.Hidden = True ' does not work
'oWB.Sheets(1).Collumns(10).EntireColumn.Hidden = True ' does not work
'oWB.Sheets(1).Collumns(1).Hide ' Does not work
'oWB.Sheets(1).Collumns(1).Visible = False ' Does not work
'StartCell filling with Q at row 8
RowStart = 8
CollumnStart = 1 'offset for data on spreadsheet
'Check record length & set this for formatting purposes
rst.MoveFirst
rst.MoveLast
NumRows = rst.RecordCount
rst.MoveFirst
'end check record length for formatting
'Check record width & set this for formatting purposes
NumCollumns = rst.Fields.Count
'Add the field names as column headers (optional)
For i = 0 To rst.Fields.Count - 1
oWB.Sheets(1).Cells(RowStart, i + 1 + CollumnStart).Value = rst.Fields(i).Name 'Reads name in from Database, 2 is for begin in second collumn (need to change if QUESIDNUM is added)
Next
TempString = RowStart & ":" & RowStart ' make string to define range definition based on RowStart
oWB.Sheets(1).Range(TempString).Font.Bold = True
oWB.Sheets(1).Cells(RowStart + 1, 1 + CollumnStart).CopyFromRecordset rst 'Copies in recordset - offset 1 for header data
oWB.Sheets(1).Name = "QuestionList" 'Set Worksheet Name
Set oSheet = oWB.ActiveSheet
Set oRng = oSheet.Range("B1", "E1") 'range is set from A1-> D1
oSheet.Range("B1").ColumnWidth = 15 'works
oSheet.Range("C1").ColumnWidth = 50 'works
oSheet.Range("D1").ColumnWidth = 50 'works
'Use with selection method - select question area
'Dim SetLineStyle As String
'SetLineStyle = xlContinuous
'Need better way (with numbers) to select ranges within EXCEL from Access
TempString = "B" & RowStart & ":" & "G" & (NumRows + RowStart) ' still to implement collumn width setting of range
'End better range definition
With oWB.Sheets(1).Range(TempString)
.Borders.LineStyle = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlTop).LineStyle = xlContinuous
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.VerticalAlignment = xlTop
.WrapText = True
End With
'Set oResizeRange = oSheet.Range(.Cells(1, RowStart), .Cells(3, RowStart + NumRows)) ' Does NOT work
'Set oResizeRange = oSheet.Range(Cell(1, 1), Cell(5, 6)) 'Does NOT work
'Set oResizeRange = oSheet.Range("A8:C30") 'Does work
'Clean up ADO Objects
rst.Close
Set rst = Nothing
'Create a folder if not exist
Dim strFilePath As String
Dim strFolder As String
strFolder = "C:\Temp"
strFilePath = strFolder & "\Rpt_" & Format(Now(), "yyyymmdd_HHmmss") & ".xls"
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strFolder) Then
'Create the file
FileSystem.MkDir (strFolder)
End If
'Clean up Excel Objects
oWB.Close SaveChanges:=True, FileName:=strFilePath
Set oWB = Nothing
oApp.Quit
Set oApp = Nothing
'Open the file after export to excel
Shell "EXCEL.EXE """ & strFilePath & "", vbNormalFocus
End Function
I'm working on an access database (Access 2003) and exporting queries to Excel (Excel 2002). The intention is to get the Access VBA code to format the excel file for me so that all the exports will all look the same, and allow for easy re-importing after other parties (users) have added data to the excel file.
The exporting is working OK, some formatting is working OK as well, however I have 2 major issues that are not working for me, however someone is bound to have come across this before:
- How to hide collumns in Excel (from Access VBA) specifying the collumn number (not the letter(s)).
- How to specify ranges in an excel worksheet (for formatting) using access VBA using the cell numbers (i.e. cell(1,2) , cell (1,4) which would be equivalent to B1
1).
As the recordset changes in size each time, I want to be able to automatically change the area(range) that is formatted. Retrieving the size of the recordset is not a problem, but using this result to change the range of cells that need reformatting is.
In addition there are some collumns that I want to hide to enable easier re-importing of the data later. (want to hide the data primary key)
The code that I am using is listed below. I have tried some things (as you can see from the code listed) and I've listed which don't work.
Looking forward to someone's bright idea on this one!
Thanks,
Arjanvb
'-------------------------------------------------------------------------------------------------------------------------
Public Function ExportXLS() As String
' Base methodology copied from: http://july-code.blogspot.com/2007/10/export-data-from-ms-access-to-excel.html
Dim oApp As Excel.Application 'in VBA : Tools : References " MS Excel reference library is required
Dim oWB As Excel.Workbook
Dim i As Integer
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim SQLstring As String
Dim CHANIDnum As Integer
Dim TempCounter As Integer
Dim RowStart As Integer 'to indicate which row Excel starts with putting data in
Dim CollumnStart As Integer 'to indicate which collumn Excel starts with putting data in
Dim NumRows As Integer
Dim TempString As String
Dim NumCollumns As Integer
Dim oSheet As Excel.Worksheet 'from excel example
Dim oRange As Excel.Range 'from excel example
'input channel ID number & other items for conversion to function later
CHANIDnum = 60
SQLstring = "SELECT tbl_QUES.CHANQNUM, tbl_QUES.QUESTEXT, tbl_QUES.ANSWTEXT, tbl_QUES.DATEQUES_SENT, tbl_QUES.QCURR, tbl_QUES.LOGNUMQ, tbl_QUES.QUESID, tbl_QUES.CHANID, tbl_QUES.QANSW "
SQLstring = SQLstring & "FROM tbl_QUES "
SQLstring = SQLstring & "WHERE (((tbl_QUES.DATEQUES_SENT) Is Null) AND ((tbl_QUES.QCURR)=Yes) AND ((tbl_QUES.CHANID)=" & CHANIDnum & ") AND ((tbl_QUES.QANSW)=False)) "
SQLstring = SQLstring & "ORDER BY tbl_QUES.CHANQNUM"
'end input of channel ID
'Create an instance of Excel and add a new blank workbook
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(SQLstring, dbOpenSnapshot)
Set oApp = New Excel.Application
oApp.Visible = False
Set oWB = oApp.Workbooks.Add
'Following deletes excess sheets in workbook to leave only one sheet
If oWB.Sheets.Count > 1 Then
Do While oWB.Sheets.Count > 1
oWB.Sheets(oWB.Sheets.Count).Delete
Loop
End If
'End deletion of extra sheets
'To hide collumn
'oWB.Sheets(1).Collumns("B:B").EntireColumn.Hidden = True ' does not work
'oWB.Sheets(1).Collumns(10).EntireColumn.Hidden = True ' does not work
'oWB.Sheets(1).Collumns(1).Hide ' Does not work
'oWB.Sheets(1).Collumns(1).Visible = False ' Does not work
'StartCell filling with Q at row 8
RowStart = 8
CollumnStart = 1 'offset for data on spreadsheet
'Check record length & set this for formatting purposes
rst.MoveFirst
rst.MoveLast
NumRows = rst.RecordCount
rst.MoveFirst
'end check record length for formatting
'Check record width & set this for formatting purposes
NumCollumns = rst.Fields.Count
'Add the field names as column headers (optional)
For i = 0 To rst.Fields.Count - 1
oWB.Sheets(1).Cells(RowStart, i + 1 + CollumnStart).Value = rst.Fields(i).Name 'Reads name in from Database, 2 is for begin in second collumn (need to change if QUESIDNUM is added)
Next
TempString = RowStart & ":" & RowStart ' make string to define range definition based on RowStart
oWB.Sheets(1).Range(TempString).Font.Bold = True
oWB.Sheets(1).Cells(RowStart + 1, 1 + CollumnStart).CopyFromRecordset rst 'Copies in recordset - offset 1 for header data
oWB.Sheets(1).Name = "QuestionList" 'Set Worksheet Name
Set oSheet = oWB.ActiveSheet
Set oRng = oSheet.Range("B1", "E1") 'range is set from A1-> D1
oSheet.Range("B1").ColumnWidth = 15 'works
oSheet.Range("C1").ColumnWidth = 50 'works
oSheet.Range("D1").ColumnWidth = 50 'works
'Use with selection method - select question area
'Dim SetLineStyle As String
'SetLineStyle = xlContinuous
'Need better way (with numbers) to select ranges within EXCEL from Access
TempString = "B" & RowStart & ":" & "G" & (NumRows + RowStart) ' still to implement collumn width setting of range
'End better range definition
With oWB.Sheets(1).Range(TempString)
.Borders.LineStyle = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlTop).LineStyle = xlContinuous
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.VerticalAlignment = xlTop
.WrapText = True
End With
'Set oResizeRange = oSheet.Range(.Cells(1, RowStart), .Cells(3, RowStart + NumRows)) ' Does NOT work
'Set oResizeRange = oSheet.Range(Cell(1, 1), Cell(5, 6)) 'Does NOT work
'Set oResizeRange = oSheet.Range("A8:C30") 'Does work
'Clean up ADO Objects
rst.Close
Set rst = Nothing
'Create a folder if not exist
Dim strFilePath As String
Dim strFolder As String
strFolder = "C:\Temp"
strFilePath = strFolder & "\Rpt_" & Format(Now(), "yyyymmdd_HHmmss") & ".xls"
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strFolder) Then
'Create the file
FileSystem.MkDir (strFolder)
End If
'Clean up Excel Objects
oWB.Close SaveChanges:=True, FileName:=strFilePath
Set oWB = Nothing
oApp.Quit
Set oApp = Nothing
'Open the file after export to excel
Shell "EXCEL.EXE """ & strFilePath & "", vbNormalFocus
End Function
