I have some queries in my Access database. I know to Export These into one Excel workbook but in different Sheets. I want to list the results of the queries into one sheet and add one empty row and a caption between the results.
I don't know how can i handle it, could someone help me?
Set a reference to Microsoft excel in the Access Vb Editor
Sub ExportQueries
Dim xl as New Excel.Application 'start up excel
dim wb as workbook
dim ws as worksheet
dim r as range
set wb = xl.workbooks.add 'add a workbook
set ws = wb.worksheets(1) 'point to first sheet
set r = ws.range("a1") 'point to a cell
r = "my first caption"
set r = r.offset(1,0)
'dim rs as new recordset 'ADO
Dim rs as recordset 'DAO
' rs.open "myquery",currentproject.connection 'ADO
Set rs = Currentdb.OPenrecordset("myquery") 'DAO
'*************************Copy field headings into excel
Dim f as field
dim x as integer
For each f in rs.Fields
r.offset(0,1)=f.name
x = x+1
next f
set r = r.offset(1,0)
'****************************End field headings
r.copyfromrecordset rs 'copy results into xl
rs.close
set r = r.end(xldown).offset(2,0) 'point to cell 2 below end of first set of results
r = "my next caption"
set r = r.offset(1,0)
rs.open "myotherquery",currentproject.connection
r.copyfromrecordset rs
rs.close
set r = r.end(xldown).offset(2,0)
'and so on
end sub
Related
Thank you in advance, I need help in completing the below code, the code currently works to add the number of rows in the Table(3) of my word template as per the available rows in excel table, the word template have one row to begin with.
How can I pass the value from excel table range Set Rng = wsSheet.Range("A2:C" & lastrow)
Option Explicit
Sub CopyToWordTemplate()
Const stWordDocument As String = "TemplateSD.docm"
Dim intNoOfRows
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lRow, i, lastrow, lastcol As Long
Dim vaData As Variant
Dim Rng As Range
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Transmittal")
lastrow = wsSheet.Range("A2").End(xlDown).Row
lastcol = wsSheet.Range("C2").End(xlToRight).Column
Set Rng = wsSheet.Range("A2:C" & lastrow)
Rng.ClearContents
Copy_Criteria_Text
lRow = wsSheet.Range("A2").End(xlDown).Row
intNoOfRows = lRow - 1
Set objWord = New Word.Application
objWord.Visible = True
Set objDoc = objWord.Documents.Open("\\Dn71\dn071\DOCUMENT CONTROL\Common\X-
Templates\Document Control\" & stWordDocument)
With objWord.ActiveDocument
.Bookmarks("Description").Range.Text = wsSheet.Range("D1").Value
.Bookmarks("RevNumber").Range.Text = "C" & wsSheet.Range("E1").Value
.Bookmarks("SubmittalNumber").Range.Text = "DN071-P02-CRC-GEN-PMT-SDA-" & wsSheet.Range("F1").Value
End With
For i = 2 To intNoOfRows
objDoc.Tables(3).Rows.Add
Next
Set objWord = Nothing
End Sub
I have the below code to get all the Sheetnames of a selected workbook. How do I get all the names of the sheets and import them into a table in the Access Database?
Public Sub PickSheets1(fileName As String)
Dim objExc As Object
Dim objWbk As Object
Dim objWsh As Object
SQLInsert = "INSERT INTO Sheets Table (Sheets) Values (objWbk.Worksheets.Name)"
Set TabInsert = CurrentDb.CreateTableDef("Sheets Table")
Set TabFields = TabInsert.CreateField("Sheets")
Set objExc = CreateObject("Excel.Application")
Set objWbk = objExc.Workbooks.Open(fileName)
Set objWsh = objWbk.Worksheets.Name
DoCmd.RunSQL SQLInsert
'For Each objWsh In objWbk.Worksheets
'TabFields("Sheets").Value objWsh.Name
Set objWsh = Nothing
objWbk.Close
Set objWbk = Nothing
objExc.Quit
Set objExc = Nothing
End Sub
So from within MSAccess you can run this code. Its uses DAO to add the sheet name to the table. Assumes that the table 'Sheets Table' with column 'SheetName' already exists.
call loadSheetNames("C:Path\Workbook.xlsx")
Function loadSheetNames(pstrWB As String)
' Access
Dim db As DAO.Database
Dim rst As DAO.Recordset
' Excel
Dim xl As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Set db = CurrentDb
Set rst = db.OpenRecordset("Sheets Table")
Set xl = CreateObject("Excel.Application")
Set xlWB = xl.Workbooks.Open(pstrWB)
For Each xlWS In xlWB.Sheets
Debug.Print xlWS.NAME
rst.AddNew
rst("SheetName") = xlWS.NAME
rst.update
Next
Set rst = Nothing
Set db = Nothing
Set xlWS = Nothing
Set xlWB = Nothing
Set xl = Nothing
End Function
If you want to run the code from within Excel, I can give you that as well.
I am fairly new to Access and I have been trying for a while to run an Access query and paste the results in Excel using VBA. I have combined some code I found and I think I almost have it but cannot figure out the last step. Here is the code:
Sub test()
Dim ws As Worksheet
Dim A As Object
Dim rs As Object
Application.DisplayAlerts = False
Set A = CreateObject("Access.Application")
Set ws = ThisWorkbook.Sheets("Sheet1")
A.Visible = True
A.OpenCurrentDatabase ("access database path")
A.DoCmd.OpenQuery ("query name")
Set rs = A.CurrentDb().QueryDefs("query name").OpenRecordset()
If Not rs.EOF Then
ws.Range("A1").CopyFromRecordset rs
End If
rs.Close
Application.DisplayAlerts = True
End Sub
I am trying to run the query and paste the results in cell A1 in sheet 1.
I get a "run time error 3219" for the line:
Set rs = A.CurrentDb().QueryDefs("query name").OpenRecordset()
Any help would be greatly appreciated.
Thanks,
G
I adapted your code to fetch data from an Access query without needing to create a full Access.Application instance. Tested and working in Excel 2010.
Const cstrPath As String = "C:\share\Access\Database2.accdb"
Const cstrQuery As String = "qryBase"
Dim dbe As Object 'DAO.DBEngine '
Dim rs As Object 'DAO.Recordset '
Dim ws As Worksheet
Application.DisplayAlerts = True 'leave alerts on during testing '
Set dbe = CreateObject("DAO.DBEngine.120")
Set rs = dbe.OpenDatabase(cstrPath).OpenRecordset(cstrQuery)
If Not rs.EOF Then
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Range("A1").CopyFromRecordset rs
End If
rs.Close
Application.DisplayAlerts = True
I would use ADODB recordset. Try the below code. Here I'm connecting to an excel workbook, but you can use the same logic for access database, you just need to change the connection string.
Private con As ADODB.Connection
Private ra As ADODB.Recordset
' SqlString = SQL Query
' Sht = Sheet Name, where the output needs to be displayed
' Rng = Range ("C5"), where the output needs to be displayed
Sub DoSql(SqlString As String, Sht As String, Rng As String, Optional IncludeHeading As Boolean = False)
Dim a As String
Dim res As Variant
Set con = New ADODB.Connection
Set ra = New ADODB.Recordset
res = ""
'a = Set the appropriate connection string for your database
'The below connection is referring to the same excel workbook which contains the macro
a = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" & ThisWorkbook.FullName & """;Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
'MsgBox a
'MsgBox SqlString
If Not Left("" & con, 8) = "Provider" Then
con.Open a
End If
If Not ra.State = 0 Then
ra.Close
End If
ra.Open SqlString, con
If Not (ra.EOF And ra.BOF) Then
ra.MoveFirst
Sheets(Sht).Select
If IncludeHeading = True Then
For intColIndex = 0 To ra.Fields.Count - 1
Range(Rng).Offset(0, intColIndex).Value = ra.Fields(intColIndex).Name
Next
Range(Rng).Offset(1, 0).CopyFromRecordset ra
Else
Range(Rng).CopyFromRecordset ra
End If
End If
ra.Close
con.Close
End Sub
I need VBA Code to get header bookmark in the Excel UserForm1 Textbox. Please assist me. I have got the page count, but not able to get this. I have placed the Code below, which I've tried, but it is not working.
I get error at:
Set wbk = ObjExcel.Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
and
wst.txtstatementof.Text = "MyBookmark"
Thanks in advance.
Sub ExportBookmarksToExcel()
Dim bk As Bookmark
Dim appXl As Excel.Application
Dim wbk As Excel.Workbook
Dim wst As Excel.Worksheet
Dim x As UserForm1
Set appXl = CreateObject("Excel.Application")
Set wbk = ObjExcel.Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
With appXl
.Visible = True
Set wbk = .Workbooks.Add
Set wst = wbk.UserForm1
wst.txtstatementof.Text = "MyBookmark"
End With
'For each bk In ActiveDocument.Bookmarks
'lRow = lRow + 1
' wst.x.UserForm1.txtstatementof.Text = bk.Name
'wst.Cells(lRow, 2) = bk.Range.Text
'Next bk
'wst.UsedRange.Columns.AutoFit
End Sub
Actually, you weren't far from success. Of course, this must fail:-
Set appXl = CreateObject("Excel.Application")
Set wbk = ObjExcel.Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
You can see that your Excel application is called appXl. Therefore it can't respond to ObjExcel.Workbooks.Open.
Below is the code that works.
Sub ExportBookmarksToExcel()
' MS Word variables:
Dim Bk As Bookmark
Dim R As Long
' MS Excel variables:
Dim appXl As Excel.Application
Dim Wbk As Excel.Workbook
Dim Wst As Excel.Worksheet
Set appXl = CreateObject("Excel.Application")
With appXl
.Visible = True
' Set Wbk = .Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
Set Wbk = .Workbooks.Add
Set Wst = Wbk.Worksheets(1)
' Wst.txtstatementof.Text = "MyBookmark" ' what is "txtstatementof" ?
End With
R = 2 ' keep Row 1 for captions
For Each Bk In ActiveDocument.Bookmarks
Wst.Cells(R, 1) = Bk.Name
Wst.Cells(R, 2) = Bk.Range.Text
R = R + 1
Next Bk
Wst.UsedRange.Columns.AutoFit
End Sub
I'm a bit of newbie when it comes to these things, so apologies if this is a stupid question.
I need to run an SQL query from a piece of VBA. The query is a little odd, because it contains a VBA variable in its function. Otherwise everything is pretty straight forward. The VBA should call the query and then insert it into a client excel document.
Every time I run the query within Access everything is fine, the function returns the correct value and filters down the columns. Every time I run it from VBA in Excel it says "Run-Time Error "3085": Undefined Function 'CutOff' in expression.
I've look for info and have found old sites saying that Access 2003 sometimes has an issue doing this sort of thing, but I'm running 2010 (I think). Just hoping the problem is solve-able and greatly appreciate any advice.
The query is as follows :
SELECT [<TableName>].ID...*
FROM [<TableName>]
WHERE ((([<TableName>].ID)>CutOff()))
ORDER BY [<TableName>]].ID;
Public Function Cutoff()
Dim WB1 As Excel.Workbook, WS1 As Excel.Worksheet
Dim y As Long
Set WB1 = Workbooks.Open("C:\filepath.z.xlsm")
Set WS1 = WB1.Sheets("Sheet2")
y = WS1.Range("A1").End(xlDown).Offset(0, 0).Value
'Debug.Print y
Cutoff = y
'Debug.Print Cutoff
End Function
The VBA that runs it is operated from Excel. I have tried the following:
Sub Export2()
Dim db2 As Database
Dim rs2 As DAO.Recordset, i As Long, sFormat As String
Dim WB2 As Excel.Workbook, WS2 As Excel.Worksheet
Set WB2 = Workbooks.Open("C:\FilePath.z.xlsm")
Set WS2 = WB.Sheets("Sheet2")
Set db2 = OpenDatabase("C:\FilePath.x.mdb")
Set qd2 = db2.QueryDefs("ExportCount")
Set rs2 = qd2.OpenRecordset()
If rs2.EOF Then
GoTo EndLoop
End If
WS2.Range("a1").End(xlsDown).Offset(1, 0).CopyFromRecordset rs2
WS2.Cells.EntireColumn.AutoFit: WS2.Cells.EntireRow.AutoFit
EndLoop:
Set WB = Nothing
Set WS2 = Nothing
Set db2 = Nothing
Set qd2 = Nothing
Set rs2 = Nothing
End Sub
EDIT:
Have also tried:
Sub SQLquery1()
Dim WB1 As Excel.Workbook, WS1 As Excel.Worksheet
Dim wt As DAO.Database
Dim we As DAO.Recordset
Dim wd As DAO.QueryDef
Set WB1 = Workbooks.Open("C:\x.xlsm")
Set WS1 = WB1.Sheets("Sheet2")
mySQLVariable = WS1.Range("A1").End(xlDown).Offset(0, 0).Value
'Debug.Print mySQLVariable
Set wt = OpenDatabase("C:\z.mdb")
Set wd = wt.QueryDefs("ExportCount")
Set we = wd.OpenRecordset("h")
WS2.Range("a1").End(xlsDown).Offset(1, 0).CopyFromRecordset wd
WS2.Cells.EntireColumn.AutoFit: WS2.Cells.EntireRow.AutoFit
Set WB1 = Nothing
Set WS1 = Nothing
Set wt = Nothing
Set we = Nothing
Set wd = Nothing
End Sub
EDIT2
Sub CreateQueryDef()
Dim WB1 As Excel.Workbook, WS1 As Excel.Worksheet
Dim dbPP As Database
Dim qdfTemp As QueryDef
Dim Counter As DAO.Recordset
Dim mySQLVariable As String
Dim rs5 As DAO.Recordset
Set dbPP = OpenDatabase("C:\filepath\z.mdb")
Set Counter = dbPP.OpenRecordset("j")
Set WB1 = Workbooks.Open("C:\filepath\x.xlsm")
Set WS1 = WB1.Sheets("Sheet2")
mySQLVariable = WS1.Range("A1").End(xlDown).Offset(0, 0).Value
'Debug.Print mySQLVariable
With dbPP
Set qdfTemp = dbPP.CreateQueryDef("NewQueryDef", "SELECT * FROM [j]")
'WHERE ((j.[ID])=>(mySQLVariable)))") I can't get the syntax of these lines right - they are supposed to all be on the same line
Set rs5 = qdfTemp.OpenRecordset() ' maybe Set rs5 = qdfTemp.OpenRecordset("NewQueryDef")?
End With
WS1.Range("a1").End(xlsDown).Offset(1, 0).CopyFromRecordset rs5
WS1.Cells.EntireColumn.AutoFit: WS2.Cells.EntireRow.AutoFit
dbPP.QueryDefs.Delete "NewQueryDef"
End Sub
Or
Sub CreateQueryDef()
Dim dbPP As Database
Dim qdfTemp As QueryDef
Dim Counter As DAO.Recordset
Dim mySQLVariable As String
Dim rs5 As DAO.Recordset
Set dbPP = OpenDatabase("C:\filepath\z.mdb")
Set Counter = dbPP.OpenRecordset("j")
mySQLVariable = CutOff
'Debug.Print mySQLVariable
With dbPP
Set qdfTemp = dbPP.CreateQueryDef("NewQueryDef", "SELECT * FROM [j] WHERE ((j.[ID])=>(mySQLVariable)))")
Set rs5 = qdfTemp.OpenRecordset("NewQueryDef")
End With
WS1.Range("A1").End(xlsDown).Offset(1, 0).CopyFromRecordset rs5
WS1.Cells.EntireColumn.AutoFit: WS2.Cells.EntireRow.AutoFit
dbPP.QueryDefs.Delete "NewQueryDef"
dbPP.Close
Set dbPP = Nothing
Set qdfTemp = Nothing
Set Counter = Nothing
Set mySQLVariable = Nothing
Set rs5 = Nothing
End Sub
Public Function Cutoff()
Dim WB1 As Excel.Workbook, WS1 As Excel.Worksheet
Dim y As Long
Set WB1 = Workbooks.Open("C:\filepath.z.xlsm")
Set WS1 = WB1.Sheets("Sheet2")
y = WS1.Range("A1").End(xlDown).Offset(0, 0).Value
'Debug.Print y
Cutoff = y
'Debug.Print Cutoff
End Function
Worked out what I was doing wrong.
The current value of the variable needs to be inserted into an SQL string written in VBA and passed to Access as a temporary query. The value of the variable is fixed by the time it is handed to Access, so Access doesn't need to run a macro to retrieve it, which would require the database to be open with macros enabled e.g.:
Public y As String
Sub definey()
y = (VariableInput)
Call Query
End Sub
Sub Query
Dim q As DAO.Database
Dim s As DAO.Recordset
Dim mySQLVariable As String
Dim strSQL As String
mySQLVariable = y
strSQL = "SELECT * FROM [Table1] WHERE (((Table1.ID)>" & "Chr$36 MySQLVariable Chr$36"))
'I'm free writing, not copying from code, so apologies if this isn't quite right
Set q = OpenDatabase("Filepath\h.mdb")
Set s = q.OpenRecordset(strSQL)
'... then copy to workbook.
End Sub