This is my code to run SQL on a worksheet in an external closed workbook...
Sub SQL()
GetWorksheetData "\\oak.fg.rbc.com\eu\Shared\Paul Brand Dev\HALO_C40.xls", "SELECT * FROM [Sheet3$]", ThisWorkbook.Worksheets(2).Range("A1")
End Sub
Sub GetWorksheetData(strSourceFile As String, strSQL As String, TargetCell As Range)
Dim db As DAO.Database, rs As DAO.Recordset, f As Integer, r As Long
If TargetCell Is Nothing Then Exit Sub
On Error Resume Next
Set db = OpenDatabase(strSourceFile, False, True, "Excel 8.0;HDR=Yes;")
On Error GoTo 0
If db Is Nothing Then
MsgBox "Can't find the file!", vbExclamation, ThisWorkbook.Name
Exit Sub
End If
' open a recordset
On Error Resume Next
Set rs = db.OpenRecordset(strSQL)
On Error GoTo 0
If rs Is Nothing Then
MsgBox "Can't open the file!", vbExclamation, ThisWorkbook.Name
db.Close
Set db = Nothing
Exit Sub
End If
RS2WS rs, TargetCell
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
If I use an XLSX file it fails with 'Can't find the file!
This happens even if I change Excel 8.0 to Excel 12.0 Xml in the arguments
Any pointers?
Related
I am using the below code to reference a table that has full path information to move (or copy) files from 1 location to another. However, it's not moving anything, but is completing per my Debug.Print message (Move Complete 2/22/2021 1:22:41 PM). Any thoughts on what I'm missing?
Additionally, I'd like to build the folder/subfolder structure where the file was located in the source...but don't know how to achieve that...and pointers on how to do this?
Sub copy_files_from_table()
Dim FSO As Object
Dim source As String
Dim destination As String
Dim SQL As String
Dim RS As DAO.Recordset
Dim db As DAO.Database
SQL = "select * from file_test"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set db = CurrentDb
Set RS = db.OpenRecordset(SQL)
source = RS!LocalFile
destination = "C:\Temp\Test"
While Not RS.EOF
If Dir(source, vbDirectory) <> "" Then
objFSO.CopyFolder source, destination:=destination '
Debug.Print "Move Folder Command Complete From: " & destination
Else
End If
RS.MoveNext
Wend
Debug.Print "Move Complete " & Now()
End Sub
Appreciate any help provided.
So far, I have gotten the following code to work on file paths <259; however, anything longer is causing the code to error. Since I'm pretty green on coding:) any suggestions how I can get around the long file path names?
Sub CopyFilesFromTable2()
On Error GoTo ErrorHandler
Dim source As String
Dim destination As String
Dim FSO As New FileSystemObject
Dim SQL As String
Dim RS As DAO.Recordset
Dim db As DAO.Database
'Test Table
SQL = "select * from file_test"
'Prod Table
'SQL = "select * from file"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set db = CurrentDb
Set RS = db.OpenRecordset(SQL)
source = RS!LocalFile
File = VBA.FileSystem.Dir(source)
destination = "D:\Temp\Test\"
With RS
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
FSO.CopyFile RS!LocalFile, destination
.MoveNext
Wend
End If
.Close
End With
ExitSub:
Set RS = Nothing
'set to nothing
MsgBox "Done!"
Exit Sub
ErrorHandler:
MsgBox Err, vbCritical
Resume ExitSub
End Sub
I'm trying to use Microsoft Access to fill out word documents with bookmarked text form fields, and then export them as PDFs. I'm struggling to produce Visual Basic code in Access that works consistently. I continue to get errors about the word documents being locked from editing. Not sure how to proceed
Code I have so far
Public Sub ExportToMGR()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim rs As DAO.Recordset
Set wApp = New Word.Application
Set wDoc = wApp.Documents.Open("C:\filepath\doc.docx")
Set rs = CurrentDb.OpenRecordset("Detail Report - Individuals")
If Not rs.EOF Then rs.MoveFirst
Do Until rs.EOF
wDoc.Bookmarks("FullName1").Range.Text = Nz(rs!ClientName, "")
wDoc.Bookmarks("FullName2").Range.Text = Nz(rs!ClientName, "")
wDoc.SaveAs2 "C:\filepath\" & "firstTest.docx"
rs.MoveNext
Loop
End Sub
Welcome to SO.
You shouldnt be opening the Word document, instead you should create a Word Template (.dotx) and add it to the documents collection by calling the .Add() method.
Once the document is filled with data, you need to call the .ExportAsFixedFormat() method to save as PDF.
See an example below.
Option Explicit
Private Sub RunMailMerge_Click()
On Error GoTo Trap
Const TEMPLATE_PATH As String = "YourTemplateFolder\WordTemplate.dotx"
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim rs As DAO.Recordset
Dim idx As Long
Set wApp = New Word.Application
wApp.Visible = False
Set rs = CurrentDb.OpenRecordset("Detail Report - Individuals")
If rs.EOF Then GoTo Leave
With rs
.MoveLast
.MoveFirst
End With
For idx = 1 To rs.RecordCount
Set wDoc = wApp.Documents.Add(TEMPLATE_PATH)
With wDoc
.Bookmarks("FullName1").Range.Text = Nz(rs!ClientName, vbNullString)
.Bookmarks("FullName2").Range.Text = Nz(rs!ClientName, vbNullString)
.ExportAsFixedFormat "DocumentPathWithExtension.pdf", wdExportFormatPDF, False, wdExportOptimizeForOnScreen
.Close wdDoNotSaveChanges
End With
Set wDoc = Nothing
rs.MoveNext
Next
Leave:
On Error Resume Next
If Not rs Is Nothing Then rs.Close
If Not wDoc Is Nothing Then wDoc.Close wdDoNotSaveChanges
If Not wApp Is Nothing Then wApp.Quit wdDoNotSaveChanges
On Error GoTo 0
Exit Sub
Trap:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub
I'm trying to populate a combo box or drop down list from an access database. I used the following website for code template. I modified it to suit my needs. I keep getting the error: 5941 The requested member of the collection does not exist"
Source code: http://www.fontstuff.com/mailbag/qword02.htm
My Code:
Private Sub Document_Open()
On Error GoTo Document_Open_Err
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=*path to database removed for post*;"
rst.Open "SELECT DISTINCT TOP 25 [Equipment] FROM tblEquipment ORDER BY [Equipment];", _
cnn, adOpenStatic
rst.MoveFirst
With ActiveDocument.FormFields("Equipment").DropDown.ListEntries
.Clear
Do
.Add rst![Equipment]
rst.MoveNext
Loop Until rst.EOF
End With
Document_Open_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
Document_Open_Err:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
Resume Document_Open_Exit
End Sub
Code that almost works:
Private Sub Document_Open()
On Error GoTo Document_Open_Err
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=*removed for post*;"
rst.Open "SELECT DISTINCT TOP 25 [Field1] FROM Equipment_List ORDER BY [Field1];", _
cnn, adOpenStatic
rst.MoveFirst
With ActiveDocument.FormFields("Equipment").DropDown.ListEntries
.Clear
Do
.Add rst![Field1]
rst.MoveNext
Loop Until rst.EOF
End With
Document_Open_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
Document_Open_Err:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
Resume Document_Open_Exit
End Sub
I'm updating my last post here. See the code below; set a reference to DAO and make a couple minor tweaks to suit your needs.
Option Explicit
'Requires a reference to the '"Microsoft DAO 3.51 (or 3.6) Object Library."
Private Sub Userform_Initialize()
Dim myDataBase As DAO.Database
Dim myActiveRecord As DAO.Recordset
Dim i As Long
'Open the database to retrieve data
Set myDataBase = OpenDatabase("D:\Data Stores\sourceAccess.mdb")
'Define the first recordset
Set myActiveRecord = myDataBase.OpenRecordset("Table1", dbOpenForwardOnly)
'Set the listbox column count
ListBox1.ColumnCount = myActiveRecord.Fields.Count
i = 0
'Loop through all the records in the table until the EOF marker is reached.
Do While Not myActiveRecord.EOF
'Use .AddItem method to add a new row for each record
ListBox1.AddItem
ListBox1.List(i, 0) = myActiveRecord.Fields("Employee Name")
ListBox1.List(i, 1) = myActiveRecord.Fields("Employee DOB")
ListBox1.List(i, 2) = myActiveRecord.Fields("Employee ID")
i = i + 1
'Get the next record
myActiveRecord.MoveNext
Loop
'Close the database and clean-up
myActiveRecord.Close
myDataBase.Close
Set myActiveRecord = Nothing
Set myDataBase = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Sub CommandButton1_Click()
Dim oRng As Word.Range
Dim oBM As Bookmarks
Set oBM = ActiveDocument.Bookmarks
Set oRng = oBM("EmpName").Range
oRng.Text = ListBox1.Text
oBM.Add "EmpName", oRng
Set oRng = oBM("EmpDOB").Range
oRng.Text = ListBox1.List(ListBox1.ListIndex, 1)
oBM.Add "EmpDOB", oRng
Set oRng = oBM("EmpID").Range
oRng.Text = ListBox1.List(ListBox1.ListIndex, 2)
oBM.Add "EmpID", oRng
Me.Hide
lbl_Exit:
Exit Sub
End Sub
Code Source:
https://gregmaxey.com/word_tip_pages/populate_userform_listbox_or_combobox.html
I want to import a query from Access to an Excel Spreadsheet. I would like the code to be adjustable sp that on sheet 1 in cell B9 I can type the name of the query as it appears in Access. So anytime I want to import a new query I just have to change the name in B9. My current VBA hardcodes the name of the query and I am not sure how to change this. This is what I have so far which imports the specific query listed.
Sub GetQuery()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim i As Long
Dim wsh As Worksheet
Set dbs = DBEngine.OpenDatabase("C:\Desktop\DataProject\Database.accdb")
Set rst = dbs.OpenRecordset("Query One")
Set wsh = Worksheets("Sheet1")
For i = 0 To rst.Fields.Count - 1
wsh.Cells(1, i + 1).Value = rst.Fields(i).Name
Next
wsh.Range("A1").Resize(ColumnSize:=rst.Fields.Count).Font.Bold = True
wsh.Range("A2").CopyFromRecordset rst
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
End Sub
Any help would be appreciated!
Well, not sure if this is really useful, but maybe you can adap it to your needs:
Option Explicit
Dim ValueB9 As String
Private Sub Worksheet_Calculate()
If ThisWorkbook.Worksheets("Sheet1").Range("B9").Value = "" Or ThisWorkbook.Worksheets("Sheet1").Range("B9").Value = ValueB9 _
Or Left(ThisWorkbook.Worksheets("Sheet1").Range("B9").Formula, 1) <> "=" Then
Exit Sub
Else
On Error GoTo ErrorHandle:
ValueB9 = ThisWorkbook.Worksheets("Sheet1").Range("B9").Value
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim i As Long
Dim wsh As Worksheet
Set dbs = DBEngine.OpenDatabase("C:\Desktop\DataProject\Database.accdb")
Set rst = dbs.OpenRecordset(ValueB9)
Set wsh = Worksheets("Sheet1")
For i = 0 To rst.Fields.Count - 1
wsh.Cells(1, i + 1).Value = rst.Fields(i).Name
Next
wsh.Range("A1").Resize(ColumnSize:=rst.Fields.Count).Font.Bold = True
wsh.Range("A2").CopyFromRecordset rst
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
End If
Exit Sub
ErrorHandle:
If Err.Number = 3078 Then
MsgBox "Query name is wrong"
Else
MsgBox Err.Description, vbCritical, "Error number " & Err.Number
End If
End Sub
This code will trigger every time you input the name of your query in cell B9 in Sheet1. You have to input the name in the cell like this:
="YOUR QUERY NAME"
If you don't type it like a formula, (for example, if you just type the name of the query) it won't trigger. If you type wrong the query name, it will throw error.
Try to adapt it to your needs.
I have been using this syntax which will export every table in a database to ONE excel workbook, but now my needs are to export every table to it's own workbook. How could this be tweaked to export each table to it's own workbook?
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
EDIT
I tried the suggestion by #HA560 but get an error of
Run-time error '91':
Object variable or With block variable not set
This is updated code:
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
Dim xl As Excel.Application
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
xl.Workbooks.Add
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
Bit of a long one which includes a three procedures. After running you should have a list of table names and TRUE/FALSE in the immediate window saying whether the export was successful.
ExportAll - The main procedure.
CreateXL - this creates an instance of Excel. It uses late binding, so no need to set references.
QueryExportToXL - this is the code to export the table. I haven't used TransferSpreadsheet as I like more control.
You need to pass a worksheet reference to the function.
You can pass either a query name or a recordset to the function.
You can pass an alternative sheet name.
The default cell to paste into is A1, but you can change this.
By default it adjusts the column widths to fit.
You can pass a collection of heading names to use instead of the field names.
There's not much error handling in there - such as passing a different number of heading names than there are fields, giving illegal sheet names.
It needs work :)
Public Sub ExportAll()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Dim oXL As Object
Dim oWrkBk As Object
Set db = CurrentDb
'Create instance of Excel.
Set oXL = CreateXL
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) <> "MSys" Then
'Create workbook with single sheet.
Set oWrkBk = oXL.WorkBooks.Add(-4167) 'xlWBATWorksheet
'Open the table recordset.
Set rst = tdf.OpenRecordset
'In the immediate window display table name and TRUE/FALSE if exported successfully.
Debug.Print tdf.Name & " - " & QueryExportToXL(oWrkBk.worksheets(1), , rst, tdf.Name)
'Save and close the workbook.
oWrkBk.SaveAs "<path to folder>" & tdf.Name
oWrkBk.Close
End If
Next tdf
End Sub
'----------------------------------------------------------------------------------
' Procedure : CreateXL
' Author : Darren Bartrup-Cook
' Date : 02/10/2014
' Purpose : Creates an instance of Excel and passes the reference back.
'-----------------------------------------------------------------------------------
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
'----------------------------------------------------------------------------------
' Procedure : QueryExportToXL
' Author : Darren Bartrup-Cook
' Date : 26/08/2014
' Purpose : Exports a named query or recordset to Excel.
'-----------------------------------------------------------------------------------
Public Function QueryExportToXL(wrkSht As Object, Optional sQueryName As String, _
Optional rst As DAO.Recordset, _
Optional SheetName As String, _
Optional rStartCell As Object, _
Optional AutoFitCols As Boolean = True, _
Optional colHeadings As Collection) As Boolean
Dim db As DAO.Database
Dim prm As DAO.Parameter
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
Dim oXLCell As Object
Dim vHeading As Variant
On Error GoTo ERROR_HANDLER
If sQueryName <> "" And rst Is Nothing Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Open the query recordset. '
'Any parameters in the query need to be evaluated first. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set db = CurrentDb
Set qdf = db.QueryDefs(sQueryName)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
End If
If rStartCell Is Nothing Then
Set rStartCell = wrkSht.cells(1, 1)
Else
If rStartCell.Parent.Name <> wrkSht.Name Then
Err.Raise 4000, , "Incorrect Start Cell parent."
End If
End If
If Not rst.BOF And Not rst.EOF Then
With wrkSht
Set oXLCell = rStartCell
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the field names from the query into row 1 of the sheet. '
'Or the alternative field names provided in a collection. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If colHeadings Is Nothing Then
For Each fld In rst.Fields
oXLCell.Value = fld.Name
Set oXLCell = oXLCell.Offset(, 1)
Next fld
Else
For Each vHeading In colHeadings
oXLCell.Value = vHeading
Set oXLCell = oXLCell.Offset(, 1)
Next vHeading
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the records from the query into row 2 of the sheet. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oXLCell = rStartCell.Offset(1, 0)
oXLCell.copyfromrecordset rst
If AutoFitCols Then
.Columns.Autofit
End If
If SheetName <> "" Then
.Name = SheetName
End If
'''''''''''''''''''''''''''''''''''''''''''
'TO DO: Has recordset imported correctly? '
'''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = True
End With
Else
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'There are no records to export, so the export has failed. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = False
End If
Set db = Nothing
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure QueryExportToXL."
Err.Clear
Resume
End Select
End Function
After for each use workbooks.add()method...out_file=activeworkbook.path