I have an "Excel Binary Workbook" with named sheets and a MS ACCESS with queries named same as workbook sheets.
For example i have a sheet like "CustomersData" and have a query named the same.
My issue is when i run this code, it exports query data to "CustomersData1" not "CustomersData"
DoCmd.TransferSpreadsheet acExport, 9, xQuery, strFilePath, True, xSheet
I was about to write function to delete firstly sheets before exporting data but i have another sheets in the same workbook have references to these sheets.
My Code:
Public Function Export_To_Excel()
On Error GoTo Export_To_Excel_Err
Dim rs As DAO.Recordset
Dim xQuery As String
Dim strPath As String
Dim i As Long
Set rs = CurrentDb.OpenRecordset("SELECT * FROM Export_Specs")
strPath = "D:\Path\To\File.xlsb"
i = 0
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Do Until rs.EOF = True
xQuery = rs("Query_Name")
DoCmd.TransferSpreadsheet acExport, 9, xQuery, strPath, True
i = i + 1
rs.MoveNext
Loop
Else
MsgBox "No queries found to export.", vbCritical, "Getting Queries"
End If
MsgBox "Finished. (" & i & ") Queries were exported successfully to " & strPath, vbInformation, "Exporting Data.."
rs.Close
Set rs = Nothing
Export_To_Excel_Exit:
Exit Function
Export_To_Excel_Err:
MsgBox Error$
Resume Export_To_Excel_Exit
End Function
I'm guessing the below replacement to your existing code should do the trick
DoCmd.TransferSpreadsheet acExport, 9, xQuery, strPath, True, "SheetName!A1:Z200"
Related
I am using VBA to refresh a Data Connection in an Excel workbook with a string variable being used for the Query to run.
When using a SELECT query this all works as it should; if it is an INSERT query, it throws an application-defined or object-defined error on Connections(ConnectionName).Refresh
The error does not repeat itself if I run the code to the point where it adds the Query string into the Data Connection and manually click the Refresh button in Excel.
Sub UploadData()
Dim wb As Workbook
Dim UploadSheetNum As Integer
Dim QueryCol As String
Dim QueryString As String
Dim CurRowString As String
Dim ConnName As String
Set wb = ThisWorkbook
UploadSheetNum = 3
QueryCol = "H"
ConnName = "DataConn"
Call VBAModule_v1.SwitchtoSheet(UploadSheetNum, wb)
For i = 1 To VBAModule_v1.GetLastRow(QueryCol)
CurRowString = wb.Sheets(UploadSheetNum).Range(QueryCol & i)
QueryString = QueryString & CurRowString & Chr(10)
Next i
Call VBAModule.RefreshConnection(ConnName, QueryString, wb)
End Sub
Sub RefreshConnection(ConnectionName As String, Query As String, wb As Workbook)
wb.Activate
On Error GoTo ExitProc
With wb.Connections(ConnectionName).ODBCConnection
.BackgroundQuery = False
.CommandText = Query
End With
wb.Connections(ConnectionName).Refresh
DoEvents
Exit Sub
ExitProc:
MsgBox ("Error Sub RefreshConnection: Issue with ConnectionName '" & _
ConnectionName & "' or Query - " & Err.Description)
End Sub
Actually just tripped over the answer. So, WorkbookConnection Object works for queries that return a result e.g Select queries, but not so much for queries that don't e.g. Insert, Update, Deletes.
The below subroutine will run an Insert query without error:
Sub RunInsertQuery(InsertTable As String, InsertValues As String)
On Error GoTo ExitProc
Dim Dataconn As Object
Set Dataconn = CreateObject("ADODB.Connection")
connstr = "DRIVER={'SQL DRIVER To Use'};" & _
"SERVER='SERVERNAME to Connect to';" & _
"PORT='PortNumber'" & _
"DATABASE='Database Name';" & _
"UID='User Id to use';" & _
"PWD='User Password';"
Dataconn.Open connstr
Dataconn.Execute "INSERT INTO " & InsertTable & " VALUES " & InsertValues
Dataconn.Close
Set Dataconn = Nothing
Exit Sub
ExitProc:
MsgBox ("Error Sub RunInsertQuery: Issue with Tablename for Insert '" & InsertTable & "' or Values being Inserted - " & Err.Description)
End Sub
how do I create excel VBA where it will update 1 table while another is going to add data on another table. Below is my code to append a table (tbl_Raw). The new table is tbl_assign with 3 columns. 2 of the column info is located in the code below while the 3rd column is just a time stamp to indicate when it was updated, but placed on another table.
On Error GoTo errHandler
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim i As long, X As long
Dim varr As String
If Me.labelChild.Caption = "Child Ref #" Then
MsgBox "You must enter Child Case.", vbOKOnly Or vbInformation, "Insufficent data"
GoTo CleanUp
End If
Set cnn = New ADODB.Connection
varr = Me.labelChild.Caption
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & "\\10.8.1.62\Chimp Change\Analysis\Database\ChimpDB.accdb"
Set rs = New ADODB.Recordset 'assign memory to the recordset
rs.Open "SELECT Parent_Ref, Child_Ref, Analyst FROM tbl_Raw WHERE Child_Ref = """ & varr & """", ActiveConnection:=cnn, CursorType:=adOpenDynamic, LockType:=adLockOptimistic, Options:=adCmdText
If rs.EOF And rs.BOF Then
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
GoTo CleanUp
End If
With rs
rs!Analyst = Me.Agents.Value
rs.Update
End With
ImportCasesForm
Me.lstCases.RowSource = "CasesList"
MsgBox "Congratulations! The Case has been assigned", vbInformation, "Assign successful"
CleanUp:
If Not rs is Nothing then
rs.close
set rs = nothing
end if
If Not cnn is Nothing then
cnn.close
set cnn = nothing
end if
Exit Sub
errHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Load Cases"
GoTo CleanUp
End Sub
I don't know if I need to do a SUB or just tweak the existing append code to also do add to another table.
Thanks.
I am currently trying to get data recorded into excel workbooks to be automatically copied over onto one "mass data" sheet. The files are named by date ex. "5-28-17". There is one for each day of the month. I'd like to collect all data into one sheet, as previously stated, in order by date descending.
I am currently using this code which should place all of the different workbooks onto their own worksheet, but I am having issues with that as well.
Option Explicit
Const path As String = "C:\Users\dt\Desktop\dt kte\"
Sub GetSheets()
Dim FileName As String
Dim wb As Workbook
Dim sheet As Worksheet
FileName = Dir(path & "*.xls*")
Do While FileName <> ""
Set wb = Workbooks.Open(FileName:=path & FileName, ReadOnly:=True)
For Each sheet In wb.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
wb.Close
FileName = Dir()
Loop
End Sub
I am trying to do this with VBA. There are 15 columns in the sheets I'm pulling from and the sheet I want to copy to. All line up perfectly. Is there a way to move the sheets from the WB I'm currently working on which should contain a worksheet for each WB onto one mass worksheet? Or can I pull all data directly from the folder with all of the workbooks saved by date to one worksheet?
I would use this AddIn.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
It will do what you want, and a whole lot more as well.
Consider using an MS Access database. Not to worry if you do not have the Office GUI .exe app installed. Because you use a Windows machine, you do have its Jet/ACE SQL Engine (.dll files).
CREATE DATABASE
Sub CreateDatabase()
On Error GoTo ErrHandle
Dim fso As Object, olDb As Object, db As Object
Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0"
Const strpath As String = "C:\Path\To\ExcelDatabase.accdb"
' CREATE DATABASE
Set fso = CreateObject("Scripting.FileSystemObject")
Set olDb = CreateObject("DAO.DBEngine.120")
If Not fso.FileExists(strpath) Then
Set db = olDb.CreateDatabase(strpath, dbLangGeneral)
End If
MsgBox "Successfully created database!", vbInformation
ExitSub:
Set db = Nothing: Set olDb = Nothing: Set fso = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitSub
End Sub
CREATE, POPULATE, EXPORT EXCEL TABLE (Excel files never opened)
Sub CreateTable()
On Error GoTo ErrHandle
Dim conn As Object, rst As Object
Dim constr As String, FileName As String, i As Integer
Const xlpath As String = "C:\Users\dt\Desktop\dt kte\"
Const accpath As String = "C:\Path\To\ExcelDatabase.accdb"
' CONNECT TO DATABASE
constr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accpath & ";"
Set conn = CreateObject("ADODB.Connection")
conn.Open constr
i = 1
FileName = Dir(xlpath & "*.xls*")
Do While FileName <> ""
If i = 1 Then
' CREATE TABLE VIA MAKE TABLE QUERY
conn.Execute "SELECT * INTO MyExcelTable" _
& " FROM [Excel 12.0 Xml;HDR=Yes;" _
& " Database=" & xlpath & FileName & "].[Sheet1$]"
Else
' POPULATE VIA APPEND QUERY
conn.Execute "INSERT INTO MyExcelTable" _
& " SELECT * FROM [Excel 12.0 Xml;HDR=Yes;" _
& " Database=" & xlpath & FileName & "].[Sheet1$]"
End If
i = i + 1
FileName = Dir()
Loop
' EXPORT TO EXCEL
Set rst = CreateObject("ADODB.Recordset")
rst.Open "SELECT * FROM MyExcelTable", conn
ThisWorkbook.Worksheets("MASS_DATA").Range("A1").CopyFromRecordset rst
' CLOSE CONNECTION
rst.Close: conn.Close
MsgBox "Successfully created and populated table!", vbInformation
ExitSub:
Set rst = Nothing: Set conn = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitSub
End Sub
I have a couple of Excel 2010 files that are mapped and linked to an Access 2010 database. I need to add another file so that three are mapped instead of two. I linked the excel file from the Import and Link tab under External Database. That seems to be okay. But when I run the code that re-maps the excel file, it gives me a runtime error 3027: Database or Object is read only. None of the files or database are read-only.
This is the code to re-map the files from a new location (ex. from the X-drive to the mail W-drive), which would also add the new excel file. Should something be added here to let me add new files?
Private Sub cmdAcceptPath_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strPath As String
Dim strFileName As String
Dim strSourceDB As String
Dim strTableName As String
Dim sList As String
Dim gMsgBoxTitle As String
On Error GoTo Error_Handler:
DoCmd.SetWarnings False
strSourceDB = Me.tExcelPath.Value
Set db = CurrentDb
strSQL = "update tblBackendFiles set setting=" & setData(strSourceDB) & " where code='SourceExcel'"
DoCmd.RunSQL strSQL
'-- Verify linked tables by refreshing
strSQL = "select setting, ExcelPath, ExcelRange from tblBackendFiles where code='SourceExcelWB'"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
'Open remapprogress
DoCmd.OpenForm "frmReMapProgress"
sList = ""
rs.MoveFirst
While Not rs.EOF
strTableName = rs!Setting
sList = sList & vbNewLine & "Deleting Table: " & strTableName
Forms!frmReMapProgress.tbProgress = sList
If TableExists(strTableName) Then
DoCmd.DeleteObject acTable, strTableName
End If
rs.MoveNext
Wend
sList = ""
'-- Relink inventory database
rs.MoveFirst
While Not rs.EOF
sList = sList & vbNewLine & "Linking Table: " & strTableName
Forms!frmReMapProgress.tbProgress = sList
Forms!frmReMapProgress.Refresh
strTableName = rs!Setting
strPath = strSourceDB & "\" & rs!ExcelPath
Debug.Print strPath
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel9, strTableName, strPath, True, rs!ExcelRange
rs.MoveNext
Wend
rs.Close
MsgBox "Re-Mapping Excel Links is Complete!"
GoTo exit_sub:
'If error occurs
Error_Handler:
MsgBox Err.number & ": " & Err.Description, vbInformation + vbOKOnly, gMsgBoxTitle
exit_sub:
Set db = Nothing
Set rs = Nothing
DoCmd.SetWarnings True
DoCmd.Close acForm, "frmReMapProgress"
DoCmd.Close acForm, "frmReMapExcel"
End Sub
You don't need to delete and recreate the link to the Excel file. Just close the linked table (if open) and replace the Excel file with the new copy.
When you open the linked table, it will read from the new file.
I have an excel file(Lets' say File X) with 2 sheets. In first sheet I display charts. Second I have data for the chart. In order to get data from chart, I need to process that data as we do in SQL like Group by, order by. Is there any way I can use oledb to read data from second sheet using VBA code in same excel file(file X)?
Thanks!!
Here's an example of using SQL to join data from two ranges: it will work fine if the file is open (as long as it has been saved, because you need a file path).
Sub SqlJoin()
Dim oConn As New ADODB.Connection
Dim oRS As New ADODB.Recordset
Dim sPath
Dim sSQL As String
sSQL = "select a.blah from <t1> a, <t2> b where a.blah = b.blah"
sSQL = Replace(sSQL, "<t1>", Rangename(Sheet1.Range("A1:A5")))
sSQL = Replace(sSQL, "<t2>", Rangename(Sheet1.Range("C1:C3")))
If ActiveWorkbook.Path <> "" Then
sPath = ActiveWorkbook.FullName
Else
MsgBox "Workbook being queried must be saved first..."
Exit Sub
End If
oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sPath & "';" & _
"Extended Properties='Excel 12.0;HDR=Yes;IMEX=1';"
oRS.Open sSQL, oConn
If Not oRS.EOF Then
Sheet1.Range("E1").CopyFromRecordset oRS
Else
MsgBox "No records found"
End If
oRS.Close
oConn.Close
End Sub
Function Rangename(r As Range) As String
Rangename = "[" & r.Parent.Name & "$" & _
r.Address(False, False) & "]"
End Function