I am using the code from Function to export query or table to MS Excel to export all the data from one Access table to a worksheet in MS Excel.
This program stores time in and time out of employees in the table.
Let's say the admin wants to filter the data from 01 Jan 19 to 15 Jan 19.
I want to put two datepickers on my form as a basis for the "From" and "To".
I want to export that selected data. How can I inject that to this code?
Public Function Export2XL(InitRow As Long, DBAccess As String, DBTable As String) As Long
Dim cn As New ADODB.Connection 'Use for the connection string
Dim cmd As New ADODB.Command 'Use for the command for the DB
Dim rs2 As New ADODB.Recordset 'Recordset return from the DB
Dim MyIndex As Integer 'Used for Index
Dim MyRecordCount As Long 'Store the number of record on the table
Dim MyFieldCount As Integer 'Store the number of fields or column
Dim ApExcel As Object 'To open Excel
Dim MyCol As String
Dim Response As Integer
Set ApExcel = CreateObject("Excel.application") 'Creates an object
ApExcel.Visible = True 'This enable you to see the process in Excel
pExcel.Workbooks.Add 'Adds a new book.
ApExcel.ActiveSheet.Name = "" & (Export_data.Label1.Caption) & ""
'Set the connection string
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;data source=" &
app.Path & "\Dbase.mdb; User ID=admin;Persist Security Info=False;JET
OLEDB:Database Password=akgtrxx21"
'Open the connection
cn.Open
'Check that the connection is open
If cn.State = 0 Then cn.Open
Set cmd.ActiveConnection = cn
cmd.CommandText = DBTable
cmd.CommandType = adCmdTable
Set rs2 = cmd.Execute
'Count the number of fields or column
MyFieldCount = rs2.Fields.count
'Fill the first line with the name of the fields
For MyIndex = 0 To MyFieldCount - 1
ApExcel.Cells(InitRow, (MyIndex + 1)).Formula = rs2.Fields(MyIndex).Name
'Write Title to a Cell
ApExcel.Cells(InitRow, (MyIndex + 1)).Font.Bold = True
ApExcel.Cells(InitRow, (MyIndex + 1)).Interior.ColorIndex = 36
ApExcel.Cells(InitRow, (MyIndex + 1)).WrapText = True
Next
'Draw border on the title line
MyCol = Chr((64 + MyIndex)) & InitRow
ApExcel.Range("A" & InitRow & ":" & MyCol).Borders.Color = RGB(0, 0, 0)
MyRecordCount = 1 + InitRow
'Fill the excel book with the values from the database
Do While rs2.EOF = False
For MyIndex = 1 To MyFieldCount
ApExcel.Cells(MyRecordCount, MyIndex).Formula = rs2((MyIndex - 1)).Value
'Write Value to a Cell
ApExcel.Cells(MyRecordCount, MyIndex).WrapText = False 'Format the Cell
Next
MyRecordCount = MyRecordCount + 1
rs2.MoveNext
If MyRecordCount > 50 Then
Exit Do
End If
Loop
'Close the connection with the DB
rs2.Close
'Return the last position in the workbook
Export2XL = MyRecordCount
Set cn = Nothing
Set cmd = Nothing
Set rs2 = Nothing
Set ApExcel = Nothing
End Function
Excel does have a way to import data from Access with no VBA at all.
Create the connection to fill your worksheet.
Go to Menu Data > Access.
You will be asked to pick an Access database and select the table you want. You probably want a query to be executed but for now, pick any table; this will be edited later.
Edit the query to what you want.
Open the connection window by clicking on the menu Data > Connections and pick the connection you have just created. Then, go to the next tab (Definition), change Command Type from Table to SQL then in command text, type your command.
Don't close the window just yet.
Add condition on your date.
If the field is called, for instance, MyDate, then add a WHERE clause like this one: (MyDate >= ? AND MyDate <= ?).
When you refresh the data, you will be prompted to give values to replace the 2 question marks, and you will have the option to designate a cell to do it. You will also have an option for the query to always use what you have defined.
Note that when done correctly, you can reorder fields and/or create formulae in the table without causing any sort of problem to Excel at all. You can also create a Total row at the bottom to sum up values, using a formula (Excel will show you a dropdown to create a SUBTOTAL formula, that is conveniently sensitive to filters.
If you want to refresh data with VBA, it takes a single line of code to do: ThisWorkbook.Connections(...).Refresh or ApExcel.Workbooks(..).Connections(...).Refresh.
PS: If you absolutely want to keep your code above, then at least make sure not to copy rs2 cell by cell (that is way to slow due to Excel event handling) but rather, do something like: ApExcel.Cells(2, 1).CopyFromRecordset rs2
Related
I have a data connection in my xlsm file, which is called "DATA".
I created my combo box and input the value from a range.
Now I need to return a result set based on the value from the combo box (drop down list). e.g. if the value in the dropdown list is "CompanyXYZ", then my query from "DATA" needs to be returned but only the data for CompanyXYZ.
The sql equivalent is:
"SELECT * FROM [query] where [column] = combobox
Issue #1
Below is my sheet("DATA"). It has a table returned by the SQL query. One of the columns is Debtor_Name. It has more than 8500 rows but only 90 are unique.
In my other sheet, I have an ActiveX ComboBox that needs to return all the unique values from DATA.Debtor_name column (the 90 unique values).
Sample VBA for issue #1:
Sub Populate_Combobox_Worksheet()
'The Excel workbook and worksheets that contain the data, as well as the range placed on that data
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnData As Range
'Variant to contain the data to be placed in the combo box.
Dim vaData As Variant
'Initialize the Excel objects
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("DATA")
'Set the range equal to the data, and then (temporarily) copy the unique values of that data to the L column.
With wsSheet
Set rnData = .Range(.Range("D1"), .Range("D10000").End(xlUp))
rnData.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("X1"), _
Unique:=True
'store the unique values in vaData
vaData = .Range(.Range("X2"), .Range("X10000").End(xlUp)).Value
'clean up the contents of the temporary data storage
.Range(.Range("X1"), .Range("X10000").End(xlUp)).ClearContents
End With
'display the unique values in vaData in the combo box already in existence on the worksheet.
With wsSheet.OLEObjects("ComboBox1").Object
.Clear
.List = vaData
.ListIndex = -1
End With
End Sub
Issue #2.
Now the end user will need to select a debtor_name from the combo box, then click on refresh data. This DATA REFRESH will need to only pull the data from SQL where debtor_name = [selected value in combo box]
I asked about for issue #2 because I did not know I had an issue with my combo box (issue #1); however, I can handle that somehow; only need help with issue #2 now.
You can use SQL to populate the ComboBox with unique values.
Option Explicit
Sub Populate_Combobox_Worksheet()
Dim con As ADODB.Connection, rs As ADODB.Recordset, SQL As String
Set con = GetConnection
' query
SQL = " SELECT DISTINCT [Debtor_name] FROM [DATA$]" & _
" WHERE [Debtor_name] IS NOT NULL" & _
" ORDER BY [Debtor_Name]"
Set rs = con.Execute(SQL)
With Sheet2.ComboBox1
.Clear
.List = Application.Transpose(rs.GetRows)
.ListIndex = -1
End With
con.Close
End Sub
Sub RefreshData()
Dim con As ADODB.Connection, rs As ADODB.Recordset, SQL As String
Set con = GetConnection
' query
SQL = " SELECT * FROM [DATA$]" & _
" WHERE [Debtor_name] = '" & Sheet2.ComboBox1.Value & "'"
Set rs = con.Execute(SQL)
Sheet2.Range("A1").CopyFromRecordset rs
con.Close
End Sub
Function GetConnection() As ADODB.Connection
Dim wb As Workbook, sCon As String
Set wb = ThisWorkbook
sCon = "Data Source=" & wb.FullName & "; " & _
"Extended Properties=""Excel 12.0;HDR=Yes;"";"
' connect
Set GetConnection = New ADODB.Connection
With GetConnection
.Provider = "Microsoft.ACE.OLEDB.12.0;"
.ConnectionString = sCon
.Open
End With
End Function
So I have a form that executes a VBA script via a macro. The purpose of said script is to open Excel, create a new workbook, gather information from several tables and export them to a formatted spreadsheet. Each person has a sheet with their name, and the relevant data is printed in said sheet. It works perfectly for the most part. Only one problem... The table in Access where the name and demographics data is gathered from is formatted to sort by last name ascending alphabetically. The VBA script exports it in the order the names were entered. I want my VBA script to respect the formatting in the database table, and I would prefer not to have to add an alphabetizing subroutine to my VBA script.
Table A Format: ID, Active, Last, First, Role, Traveler, Resident, Preceptee, Phone, Completion
Table B Format: ID, Course, Course ID, Offered, HLC, Course Type
Last in Table A called "Roster" is the field with which I want my VBA script to sort alphabetically. The database is already configured to do this.
Thanks in advance!
VBA Code:
Option Compare Database
' This module exports the database to a spreadsheet with specific formatting when called from a Macro
' Each Employee will have a sheet named thier last name which will contain all HLC modules they have completed in a list
' It is specific to this Database, but can be adapted to others.
' Version 1.0 Stable
Public Function ExportXLS(TblA As String, TblB As String, Optional names As String, Optional specific As Boolean)
'****************'
'Set up variables'
'****************'
Dim ctrA As Integer
Dim ctrB As Integer
Dim var As Long
Dim str As String
Dim excel As Object 'Pointer to Excel Application
Dim book As Object 'Pointer to Excel Workbook
Dim sheet As Object 'Pointer to Excell Sheet
Dim Roster As DAO.Recordset
Dim Course As DAO.Recordset
Dim Child As DAO.Recordset
Dim last_name As DAO.Recordset 'Matrix of pointers that will hold parts of the tables to be printed to the corresponding Excel sheets
Dim course_name As DAO.Recordset 'Matrix of pointers that will hold parts of the tables to be printed to the corresponding Excel sheets
'********************************************************'
'Initialize our tables into thier recordsets for analysis'
'********************************************************'
Set Roster = CurrentDb.OpenRecordset(TblA)
Set Course = CurrentDb.OpenRecordset(TblB)
str = "SELECT Last FROM Roster"
Set last_name = CurrentDb.OpenRecordset(str)
str = "SELECT Course FROM [Course List]"
Set course_name = CurrentDb.OpenRecordset(str)
'**************************************************************************'
'Create the new excel file with default parameters and print the cover page'
'**************************************************************************'
Set excel = CreateObject("Excel.Application")
Set book = excel.Workbooks.Add
excel.Visible = True
Set sheet = book.Worksheets("Sheet1")
str = "Coversheet"
sheet.Name = str
sheet.Range("B2") = "HLC Database Export tool V1.0"
sheet.Range("B3") = "Written by Levi T Jackson, RN, BSN"
sheet.Range("B4") = "All rights reserved, Copyright 2021"
sheet.Range("B5") = "For use only by Emory Healhtcare, and others with permissions"
'**********************************'
'Main Loop, where the magic happens'
'**********************************'
ctrA = 0
Roster.MoveFirst
last_name.MoveFirst
Do Until last_name.EOF 'Move through the list of last names in the table Roster, one at a time
If Roster!Active = True Then 'No need to report on inactive employees, use access query for that
Set Child = Roster!Completion.Value 'Open a Recordset for the multivalued field Completion in Roster
ctrB = 1
If Child.EOF = True Then 'save the number of records for printing, or set to 0
var = 0
Else
Child.MoveLast
var = Child.RecordCount
Child.MoveFirst
End If
Course.MoveLast
If Child.EOF = False Then 'Avoid errors by not processing a page if no completion records exist
Set sheet = book.sheets.Add(After:=book.Worksheets(book.Worksheets.count)) 'For active employees, make a new sheet and switch to it, and set its name to the current last name from Roster
sheet.Activate
sheet.Range("A1").SELECT
str = Roster!Last & ", " & Roster!First
sheet.Name = str
sheet.Range("B2") = "Courses Completed"
Do Until Child.EOF 'If there are records in Completion for the current name, print them, move on when done
Course.MoveFirst
course_name.MoveFirst
Do Until Course.EOF
If Course![Course ID] = CInt(Child!Value.Value) Then
sheet.Range("D" & Mid(coordinates(ctrB), 2, Len(coordinates(ctrB)) - 1)) = Course![Course ID] 'prints course ID next to the name
sheet.Range("D2") = "'" & CStr(var) & " / " & CStr(Course.RecordCount) 'Prints number of records in completions
sheet.Range("B3") = "Course Name"
sheet.Range("D3") = "Course ID"
sheet.Range(coordinates(ctrB)) = Course!Course 'Prints course name
ctrB = ctrB + 1
Course.MoveLast
Course.MoveNext
Else
Course.MoveNext
course_name.MoveNext
End If
Loop
Child.MoveNext
Loop
End If
ctrA = ctrA + 1 'I might use this later in code updates, counts how manmy records are processed
Child.Close
excel.ActiveSheet.Cells.SELECT 'Selects all of the cells
excel.ActiveSheet.Cells.EntireColumn.AutoFit 'Does the "autofit" for all columns
sheet.Range("A1").SELECT 'Selects the first cell to unselect all cells
End If
Roster.MoveNext
last_name.MoveNext
Loop
'Clean up recordsets
last_name.Close
course_name.Close
Roster.Close
Set Roster = Nothing
Course.Close
Set Course = Nothing
End Function
'Converts the iteration of the print course sub loop into a sheet coordinate cell and returns it as a string
'This function is here so that later a more complicated printing coordinate system can be easily added as the database grows larger
Private Function coordinates(num As Integer) As String
coordinates = "B" & CStr(num + 4)
End Function
Add an order by clause to your OpenRecordset statements.
Right now I am trying to export data from Excel to Access with VBA.
rst("2k2").Value = sProduct
This is an example of what I currently use which is putting the value sProduct into the column in Access called "2k2". How would I move to the next column in Access and put a value in that column? Besides the obvious using the name of that column.
Thanks!
You could set the fields to a variable and cycle through them.
Dim fld as DAO.Field
for each fld in rst.fields
'Do some stuff
next
Disclaimer: As mentioned in the comments, do not use this code in a production environment. Use it only for a DB, which you are using for a school project or anything similar. Databases are really different than an Excel Spreadsheet and the position of the columns is not always constant.
Having said this:
Option Explicit
Public Function GetColumnNameAfter(columnName As String) As String
Dim cnLogs As New ADODB.Connection
Dim rsHeaders As New ADODB.Recordset
Dim rsData As New ADODB.Recordset
Dim myCounter As Long
Dim myConn As String
Dim nameFound As Boolean
myConn = "Provider=SQLNCLI11;Server=(localdb)\MSSQLLocalDB;"
myConn = myConn & "Initial Catalog=Blog;Trusted_Connection=yes;timeout=30;"
cnLogs.Open myConn
With rsHeaders
.ActiveConnection = cnLogs
.Open "SELECT * FROM syscolumns WHERE id=OBJECT_ID('Posts')"
Do While Not rsHeaders.EOF
'Printing is fun...
'Debug.Print rsHeaders(0)
If nameFound Then
GetColumnNameAfter = rsHeaders(0)
Exit Function
End If
If columnName = rsHeaders(0) Then nameFound = True
myCounter = myCounter + 1
rsHeaders.MoveNext
Loop
.Close
End With
End Function
In the strConn change the Initial Catalog to your DB and the DB Table Posts here OBJECT_ID('Posts')" to your DB table. Then the function will return the String name of the column after the the one you have provided as a parameter.
The code loops through the Headers of a table, named "Posts", which is in a DB named Blog. Once it finds a header, named columnName, it sets the nameFound to True and returns the Name of the next column.
Once you know the name of the "Next" column, you can use the same logic as in your question.
I have been looking for a solution to inserting data into excel using vb6 code and access database. There are many cases where I need to write to an excel spreadsheet multiple times with different records of data. I have an existing workbook that I am trying to open and "save as" when I am complete. I have been able to open the excel workbook, access the sheet I am writing to, and the cells I am writing to, however I can only write to the workbook once and when I leave the scope of the open workbook the connection is closed.
I have a sub routine that creates the workbook object, opens the existing workbook and work sheet, writes to a specified cell number to insert the new data. I have looked at official support pages and it doesn't seem to have what I am looking for at this time.
Am I making this too complicated or is there a solution for this? Please help.
My current code:
Row Arrays
Private oldDataRowArray(3 To 21) As Integer
Private updatedDataRowArray(5 To 2) As Integer
Loop logic
Dim i As Integer
Dim n As Integer
i = 3
n = 5
Do While i <= UBound(oldDataRowArray) And n <= UBound(updatedDataRowArray)
EditExcelSheet txtWorkbookFileName.Text, i, n //sub routine
i = i + 3 //skip number of cells
n = n + 3 //skip number of cells
Loop
Sub Routine to Insert data into Excel
Private Sub EditStakingSheet(ByVal workbook As String, ByVal oldDataRowIndex As Integer, ByVal newDataRowIndex As Integer)
Dim objExcel As Object
Dim objWorkBook As Object
Dim objSheet As Object
Set objExcel = New Excel.Application
Set objWorkBook = objExcel.Workbooks.Open(workbook)
Set objSheet = objWorkBook.Worksheets(1)
objExcel.Visible = True
//insert old value
objSheet.Cells(oldDataRowIndex , 26).Value = "old Value"
//insert new value
objSheet.Cells(newDataRowIndex , 26).Value = "new Value"
End Sub
You could use adodb objects.
This video is a good tutorial for this.
Here is an example how you can use adodb. You need to install the activeX Data Objects Libary for this.
For .source= you can use any sql-query.
Public Function get_Value(table As String, order_by As String) As Variant
Set db_data = New ADODB.Recordset
Set db1 = New ADODB.Connection
pDB_path = "#enter db-path here"
db1.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & pDB_path & ";Persist Security Info=False;"
db1.Open
With db_data
.ActiveConnection = db1
.Source = "SELECT * FROM " & table & " ORDER BY " & order_by & " ASC"
.LockType = adLockReadOnly 'read only access to db
.CursorType = adOpenStatic 'how to update the database
.Open
End With
get_Value = TransposeArray(db_data.GetRows)
db_data.Close
End Function
I wrote this bit of VBA code that creates a SQL query dynamically based on the number of fields the user has selected and values read from an XL spreadsheet. It basically just adds "FIELD_VARIABLE=VALUE_VARIABLE OR" to the where clause and then removes the final OR after the loop ends.
It works for N number of fields added like I was hoping but my concern is security because I think I could just put like ';DROP TABLE Projects or some other malicious code into the spreadsheet from where the program is reading FIELD_VARIABLES. To a lesser extent since the query is different every time the execution path must be different and that probably slows down execution time.
I'm thinking of looking into parameterized queries or T-SQL to improve this. Was hoping one of you smart folks could point me in the right direction before I waste too much time on this. Here is the relevant VBA code:
'---loop through array of search fields and search values using the same index
'---since the arrays sizes will always be the same and create where filters dynamically
i = 1
For i = LBound(sLookupFields) To UBound(sLookupFields)
Set rngLookup = wsLookupSrc.cells(counter, lLookupCols(i))
'---clear where from last iteration through loop
SQLWhereDynamic = ""
SQLWhereDynamic = SQLWhereDynamic & " p." & sLookupFields(i) & " = '" + CStr(rngLookup.Value) & "' OR"
Next i
'---remove extra ' OR'
SQLWhereDynamic = Left(SQLWhereDynamic, (Len(SQLWhereDynamic) - 3))
SQLValue = wsLookupSrc.cells(counter, lLookupCols(1)).Value
SQLWhereDefault = "WHERE p.ClientId = " + CStr(iClientId) + ""
SQLQuery = SQLSelect + SQLWhereDefault + " AND (" + SQLWhereDynamic + ");"
Making the field name in the WHERE clause a parameter (and therefore dynamic and safe from injection) like you can with the value in the WHERE clause is impossible, I believe. However...
Here's how I would do it. Suppose you have an Excel range with all of the possible fields, search values filled in for those fields you want to search, and a data type (to be used in the code later). This below example shows two fields being searched
Field Value DataType
Sequence 131
CustomerID 200
InvoiceNumber 200
OrderNumber 200
InvoiceDate 8/14/2015 7
Item DS2 200
Location 200
ExportFile 200
DateImported 7
OnHold 11
The user fills in column 2. And the code builds the sql string
Sub MakeSQL()
Dim aSql(1 To 4) As String
Dim aWhere() As String
Dim vaFields As Variant
Dim lWhereCnt As Long
Dim lCnt As Long, i As Long
Dim cn As ADODB.Connection
Dim cmd As ADODB.Command
Dim pm As ADODB.Parameter
'Skip number three until later
aSql(1) = "SELECT *"
aSql(2) = "FROM dbo.InvoiceLine"
aSql(4) = "ORDER BY InvoiceNumber DESC;"
'Grab all the search criteria
vaFields = Sheet1.Range("A2:C11").Value
'Set up the connection
Set cn = New ADODB.Connection
cn.Open sConn
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cn
'Count how many criteria where filled in
'You could Redim Preserve your aWhere() also
On Error Resume Next
lWhereCnt = Sheet1.Range("B2:B11").SpecialCells(xlCellTypeConstants).Count
On Error GoTo 0
'If there's at least one
If lWhereCnt >= 1 Then
ReDim aWhere(1 To lWhereCnt)
'Fill in an array and create parameters
For i = LBound(vaFields, 1) To UBound(vaFields, 1)
If Len(vaFields(i, 2)) > 0 Then
lCnt = lCnt + 1
'Put in the place holder
aWhere(lCnt) = vaFields(i, 1) & "=?"
'column 3 holds the data type
Set pm = cmd.CreateParameter(vaFields(i, 1) & "_p", vaFields(i, 3), adParamInput)
pm.Value = vaFields(i, 2)
'Variable length data types (I only use varchar, you may use more)
'must have a size specified
If vaFields(i, 3) = adVarChar Then pm.Size = Len(vaFields(i, 2))
cmd.Parameters.Append pm
End If
Next i
'Fill in the "where" section of your sql statement
aSql(3) = "WHERE " & Join(aWhere, " OR ")
End If
cmd.CommandText = Join(aSql, Space(1))
'Change this line to actually execute something
Debug.Print cmd.CommandText
For i = 0 To cmd.Parameters.Count - 1
Debug.Print , cmd.Parameters(i).Name, cmd.Parameters(i).Value
Next i
cn.Close
Set cn = Nothing
End Sub
For this example, the string comes out as
SELECT * FROM dbo.InvoiceLine WHERE InvoiceDate=? OR Item=? ORDER BY InvoiceNumber DESC;
InvoiceDate_p 8/14/2015
Item_p DS2