I am having some issues with the below piece of code. The data exports fine from access to excel, however, when I go to view the excel file it says its locked for editing. Does anyone know why?
Public Sub ExportFiles()
Dim X As Object
Dim Y As Object
Dim XL As Object
Dim rs As Recordset
Set X = CreateObject("Excel.Application")
Set Y = X.Workbooks.Open("\\POISE\Data\LCS\DomGroup\ICE NMW Performance and DQ\Tasking MI\2014-15\Production Pack Template\OFFICIAL SENSITIVE Tasking Team Production Pack.xlsx")
Set XL = Y.Sheets("Tasking Records")
Set rs = CurrentDb.OpenRecordset("ALL")
XL.Range("A2").CopyFromRecordset rs
Y.SaveAs "\\POISE\Data\LCS\DomGroup\ICE NMW Performance and DQ\Tasking MI\2014-15\Production Pack Output\" & "Tasking " & "Week " & Format(FiscalWeek, "w") & Format(Date, "yyyymmdd") & ".xlsx"
X.Visible = False
Set X = Nothing
Set Y = Nothing
Set XL = Nothing
rs.Close
Set rs = Nothing
End Sub
You're not closing the excel application properly. You need to close the workbook and quit excel before setting the objects to nothing.
For more information see my answer to Remove Excel Task from Task Manager after running vba.
Public Sub ExportFiles()
Dim X As Object
Dim Y As Object
Dim XL As Object
Dim rs As Recordset
Set X = CreateObject("Excel.Application")
Set Y = X.Workbooks.Open("\\POISE\Data\LCS\DomGroup\ICE NMW Performance and DQ\Tasking MI\2014-15\Production Pack Template\OFFICIAL SENSITIVE Tasking Team Production Pack.xlsx")
Set XL = Y.Sheets("Tasking Records")
Set rs = CurrentDb.OpenRecordset("ALL")
XL.Range("A2").CopyFromRecordset rs
Y.SaveAs "\\POISE\Data\LCS\DomGroup\ICE NMW Performance and DQ\Tasking MI\2014-15\Production Pack Output\" & "Tasking " & "Week " & Format(FiscalWeek, "w") & Format(Date, "yyyymmdd") & ".xlsx"
X.Visible = False
' remove objects in reverse order to creation
Set XL = Nothing
' close workbook before quitting excel
Y.Close
Set Y = Nothing
'close excel before setting it to nothing
X.Quit
Set X = Nothing
rs.Close
Set rs = Nothing
Related
I am trying to create VBscript to export process data from a SCADA system (WinCC RT Professional) to periodically archive all process variables. The data are stored in SQL table that can be accessed through a connectivity pack. I managed to make the script working when exporting one tag (process variable), but I would like to loop over all tags in the system (about 60), collect them in another recordset and then all data from this recordset save in one csv-file. I have created RecSet that collects all variables (fields) of one tag (Time, Process Variable etc.), I only need values from Field 4 (the same field for all tags). I would then like to copy this field in another recordset - RecSetColl which collects all required data (Field 4) from all tags and finally save them in the CSV file. Thank you very much for any help.
Sub DataExport()
Dim fso 'FileSystemObject
Dim f 'File
Dim ts 'TextStream
Dim path 'Path
Dim ArchiveDate 'Archive date
'Name of CSV-file
ArchiveDate = ArchiveDate & Now
ArchiveDate = Replace(ArchiveDate,"/","")
ArchiveDate = Replace(ArchiveDate," ","")
ArchiveDate = Replace(ArchiveDate,":","")
ArchiveDate = "MDF_" & ArchiveDate
'Path to the csv-file
path = "D:\Historical_data\" & ArchiveDate & ".csv"
'Create Filesystemobject and CSV-file if not exists:
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(path) Then
fso.CreateTextFile(path)
Else
MsgBox "File already exists!"
Exit Sub
End If
'Create object and open it for writing
Set f = fso.GetFile(path)
Set ts = f.OpenAsTextStream(2,-2)
ts.WriteLine("Tag-Name;ValueID;Date/Time;Process-Value") 'Header
'Generate String for the CSV-Filename
Dim Pro 'Provider
Dim DSN 'Data Source Name
Dim DS 'Data Source
Dim ConnString 'Connection String
Dim MachineNameRT 'Name of the PC from WinCC-RT
Dim DSNRT 'Data Source Name from WinnCC-RT
Dim Conn 'Connection to ADODB
Dim RecSet 'RecordSet
Dim RecSetColl 'RecordSet storing data to be saved to the CSV-file
Dim Command 'Query
Dim CommandText 'Command-Text
Dim i
'Read the name of the PC-Station and the DSN-Name from WinCC-RT
Set MachineNameRT = HMIRuntime.Tags("#LocalMachineName")
Set DSNRT = HMIRuntime.Tags("#DatasourceNameRT")
'Preparing the Connection-String
Pro = "Provider=WinCCOLEDBProvider.1;" 'First instance of WinCCOLEDB
DSN = "Catalog=" & DSNRT.Read & ";" 'Name of Runtime-Database
DS = "Data Source=" & MachineNameRT.Read & "\WinCC" 'Data Source
'Build the complete String:
ConnString = Pro + DSN + DS
'Make Connection
Set Conn = CreateObject("ADODB.Connection")
Conn.ConnectionString = ConnString
Conn.CursorLocation = 3
Conn.open
Set RecSetColl = CreateObject("ADODB.Recordset")
With RecSetColl.Fields
.Append "Time1", adChar
.Append "AHU_RUN", adChar
.Append "Time2", adChar
.Append "TT01", adChar
.Append "TT02", adChar
End With
For i = 0 To 4
Set RecSet = CreateObject("ADODB.Recordset")
Set Command = CreateObject("ADODB.Command")
Command.CommandType = 1
Set Command.ActiveConnection = Conn
'Building the complete string
CommandText = "Tag:R," & i & ",'0000-00-00 12:00:00.000','0000-00-00 00:00:00.000'"
Command.CommandText = CommandText
Set RecSet = Command.Execute
RecSet.MoveFirst
RecSetColl.Fields(i) = RecSet.Fields(4) 'RecSet.Fields(4) stores a proces value
RecSet.Close
Set RecSet = Nothing
Set Command = Nothing
Next
'Writing recordsets to CSV-file
Do While Not RecSetColl.EOF
ts.WriteLine (RecSetColl.Fields(0).Value & ";" & RecSetColl.Fields(1).Value & ";" & RecSetColl.Fields(2).Value & ";" & RecSetColl.Fields(3).Value & ";" & RecSetColl.Fields(4).Value & ";" & RecSetColl.Fields(5).Value)
RecSetColl.MoveNext
Loop
RecSetColl.Close
Set RecSetColl = Nothing
Conn.close
Set Conn = Nothing
ts.Close
Set fso = Nothing
Set f = Nothing
Set ts = Nothing
End Sub
I do not really know whats not working, but a guess;
Does ValueID = 0 , (the "i" in the "for 0 to 4" ) exist in your project?
In the table "Archive" you will find the valid ValueIDs, starts with "1" in all my projects. It's simple to see in SQL Management Studio, perhaps sometimes 0 exist.
To get all the values exported, query the "Archive" table first and then ask for data in a loop using whatever ValueID's is returned.
//PerD
I want to have a button on the Excel spreadsheet and have the data copied to the Access table.
The range is an auto-populated field from another sheet in the same workbook.
I tried few codes to make this happen, but I either get an error 1004: application-defined or object-defined error, or no error but data not being copied in Access DB.
My code is copied below.
Sub Export_Data()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim dbPath
Dim x As Long, i As Long
dbPath = "H:\RFD\RequestForData.accdb"
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.Open Source:="tblRequests", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
rst.AddNew
For i = 1 To 13
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
MsgBox " The data has been successfully sent to the access database"
Set rst = Nothing
Set cnn = Nothing
End Sub
Looking at your Subroutine I see two things that can make it not to work:
rst(Cells(1, i).Value) = Cells(x, i).Value <- Where is 'x' initialized?
There is only one loop that moves over the fields but I think it should be another loop for the rows in the Excel.
With this two changes, the loop when the records are save could become something like this:
For x = 1 TO lastRow ' Last row has to be calculated somehow
rst.AddNew
For i = 1 To 13
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x
Hope it helps.
Ok, I have searched and searched and have not found an answer. I have a very simple code that exports the contents of some tables into an excel workbook and then I want to save the workbook in the same directory as the database. My code works just fine on my computer, but when I try to load the database on a colleague's, the tables export just fine, but the excel workbook will not save as the given name-it just gives a prompt and asks whether you want to save Book1.xlsx If I disable the messages, it just doesn't save it at all. (His curDir is different than mine, but I checked and the workbooks aren't in there either) The database was created in Access 2013 and both computers have Access 2013 installed, although the second one (the one that's not working) also has Access and Excel 2010 installed. The workbook is opening in Excel 2013 though. I tried changing it to an .xls file and specifying the file format number in the saveas command, but that didn't work. I am including the code that works on my computer. I'm sure this is something simple, please help. Oh I should say, it worked fine the first time, but now it won't work (and I deleted the first copy, so I know its not that it doesn't want to overwrite) I'm pulling my hair out!
Public Function DeleteExcessPendragonRecords()
On Error GoTo DeleteExcessPendragonRecords_err
Dim strSQL1 As String
Dim strSQL2 As String
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim osheet As Excel.Worksheet
Dim strSQLlinkedtables As String
Dim rs3 As DAO.Recordset
Dim currdirpath As String
currdirpath = CurDir()
'Exporting all tables into Excel Spreadsheet
Set db = CurrentDb
DoCmd.Hourglass True
Call RefreshSharePointLinks
strSQLlinkedtables = "SELECT tbl_PendragonTableNames.LocalLink FROM tbl_PendragonTableNames WHERE tbl_PendragonTableNames.ID < 15"
Set rs1 = db.OpenRecordset(strSQLlinkedtables)
Set oXL = CreateObject("Excel.Application")
oXL.Visible = True
Set oWB = oXL.Workbooks.Add
On Error Resume Next
Do Until rs1.EOF
oWB.Sheets.Add
Set osheet = oWB.ActiveSheet
osheet.Name = rs1.Fields(0)
On Error Resume Next
Dim Linkedtable As String
Linkedtable = rs1.Fields(0)
Set rs2 = db.OpenRecordset(Linkedtable)
For i = 0 To rs2.Fields.Count - 1
osheet.Cells(1, i + 1).value = rs2.Fields(i).Name
Next i
osheet.Range("A2").CopyFromRecordset rs2
rs1.MoveNext
Loop
oWB.SaveAs currdirpath & "\PendragonBackup_" & Format(Date, "yyyymmdd") & ".xlsx"
rs2.Close
rs1.Close
oWB.Close
oXL.Close
oXL.Quit
db.Close
Set oWB = Nothing
Set oXL = Nothing
Set rs2 = Nothing
Set rs1 = Nothing
Set db = Nothing
'Code continues after this, but this is the relevant part
Instead of
currdirpath = CurDir()
try:
currdirpath = CurrentProject.Path
Help! I have a database that I'm using to open an Excel template, export the results of a QueryDef to the acitve worksheet, then save that file with a new file name. Sounds easy enough. The problem that I'm running into is getting the results to export into an active worksheet by using DoCmd.TransferSpreadsheet. It does everything that I need it to, except for actually transfering the data... Which means, it's pretty much useless. Any help would be GREATLY appreciated. I'm about to pull my hair out. Thank you in advance.
Creating the QDF
Set qdf = db.CreateQueryDef("" & strCrt, "SELECT [Zones Asset Information].* FROM " & _
"[Zones Asset Information] WHERE [Zones Asset Informaiton].[Invoice Number] " = '" & strCrt & "';")
Opening the Template
Set xlWB = xlApp.Workbooks.Open(WB_PATH)
Set xlWS = xlWB.Sheets(3)
xlWS.Activate
Trying to Export
DoCmd.TransferSpreadsheet acExport, 10, "" & strCrt, , True, "orig data" 'Don't know how to specify Active Worksheet instead of a filename?!?
DoCmd.DeleteObject acQuery, "" & strCrt
Saving the File
sSaveAsFileName = FLDR_PATH & "Accounting_Breakdown_Zones_Invoice_xxxxxx.xlsx"
Debug.Print "sSaveAsFileName: " & sSaveAsFileName
xlWB.SaveAs sSaveAsFileName
There are two ways of exporting data from Access to Excel:
Opening an MsExcel object and using its methods to manipulate the Excel
Exporting data using the TransferSpreadsheet method
You are doing a mix of both, which is why you are not getting the result.
TransferSpreadsheet will export the given query to the specified file, but you cannot specify the worksheet.
If specifying worksheet is important, you will have to do it with an Excel object, and send the information cell by cell, a lot more work, if it justifies the cause.
E Mett, Thank you for the direction. Had to rework the process which doesn't 100% agree with the post title now, but thought I would share in case anyone else needed something similar. Thanks again!!
Private Sub ExportTable_MultipleWB()
Dim db As DAO.Database, rs As DAO.Recordset, rs2 As DAO.Recordset, strFilter As String, strFilter2 As String, _
sSaveAsFileName As String
Dim xlApp As Excel.Application, xlWB As Excel.Workbook, xlWS As Excel.Worksheet
Dim bolIsExcelRunning As Boolean
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT DISTINCT [mytable].[PO Number], [mytable].[Invoice Number] " & _
"FROM [mytable] ORDER BY [mytable].[PO Number], [mytable].[Invoice Number];", dbOpenSnapshot)
rs.MoveFirst
Do While Not rs.EOF
strFilter = rs.Fields(1).Value
strFilter2 = rs.Fields(0).Value
Set rs2 = db.OpenRecordset("SELECT [mytable].* FROM [mytable] WHERE [mytable].[Invoice Number] = '" & strFilter & "';")
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
Else
bolIsExcelRunning = True
End If
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(WB_PATH)
Set xlWS = xlWB.Sheets(3)
xlWS.Activate
With xlWS
For iCols = 0 To rs2.Fields.Count - 1
xlWS.Cells(1, iCols + 1).Value = rs2.Fields(iCols).Name
Next
xlWS.Range(xlWS.Cells(1, 1), _
xlWS.Cells(1, rs2.Fields.Count)).Font.Bold = True
xlWS.Range("A2").CopyFromRecordset rs2
End With
sSaveAsFileName = FLDR_PATH & "myfilename_" & strFilter & "_PO-" & strFilter2 & ".xlsx"
Debug.Print "sSaveAsFileName: " & sSaveAsFileName
xlWB.SaveAs sSaveAsFileName
Set xlWS = Nothing
xlWB.Close False
Set xlWB = Nothing
rs.MoveNext
Loop
rs.Close
rs2.Close
If Not bolIsExcelRunning Then
xlApp.Quit
End If
Set xlApp = Nothing
Set rs = Nothing
Set rs2 = Nothing
Set db = Nothing
End Sub
I've taken a different approach to a work project and I'm running into a wall. I've Google'd everything that I can think to Google and searched multiple forums before coming back to S.O. to ask for more help. I have a form in Access that let's users enter a customer/division combination, checks to make sure that there is an existing file path for that customer, then opens excel template files and saves them to the correct folder with a customer specific file name. This all seems to be working fine. Here's the part that has me completely stumped. The next part of this would be to open two of the excel files assigning, the Workbooks as variables xlWB1 and xlWB2 and the Worksheets as xlWS1 and xlWS2(Sheet1). I need to start in xlWB1.xlWS1.(cell D2) and do a VLookup on the value (item number) of that cell against the values of the cells in the range xlWB2.xlWS2.Range(D2:D1937). My hope was to count the total number of rows in each worksheet before starting the VLookup so that I could assign that value to a variable and use that variable to define the bottom of the range. I'm going to apologize in advance if the answer to this is something simple. I've never tried to perform any operations in Excel from Access using VBA, so I'm also struggling with the syntax. Please let me know if my question isn't clear or if there is any additional information that you need. I've pasted my starting code below.
UPDATED CODE IN CASE ANYONE ELSE NEEDS TO USE IT! THANK YOU ALL FOR THE HELP!!
Sub modExcel_SixMonth()
Const WB_PATH As String = "\\FMI-FS\Users\sharp-c\Desktop\TestDir\"
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim xlRng As Excel.Range
Dim rCount As Long
Dim xlWB2 As Excel.Workbook
Dim xlWS2 As Excel.Worksheet
Dim rCount2 As Long
Dim sFormula As String
Dim i As Long
Dim xlSheetName As String
Dim bolIsExcelRunning As Boolean
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
Else
bolIsExcelRunning = True
End If
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open(WB_PATH & "acct 900860 Kentucky RSTS.xlsx")
Set xlWS = xlWB.Sheets(1)
Set xlWB2 = xlApp.Workbooks.Open(WB_PATH & "acct 900860 six months.xlsx")
Set xlWS2 = xlWB2.Sheets(1)
xlSheetName = xlWS2.Name
' rCount: RSTS Row Count
rCount = xlWS.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
Debug.Print "rCount : " & rCount
' rCount2: 6 Months Row Count
rCount2 = xlWS2.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
Debug.Print "rCount2 : " & rCount2
xlWS.Activate
With xlWS
For i = 2 To rCount
sFormula = "=VLOOKUP(C" & i & ", '" & WB_PATH & "[" & "acct 900860 six months.xlsx" & "]" & _
xlSheetName & "'!$D$2:$D$" & rCount2 & ", 1, 0)"
Debug.Print sFormula
.Range("D" & i).Formula = sFormula
DoEvents
Next
End With
xlWB.Save
xlWB2.Close False 'Closes WB Without Saving Changes
Set xlWB2 = Nothing
Set xlWS = Nothing
xlWB.Close
Set xlWB = Nothing
If Not bolIsExcelRunning Then
xlApp.Quit
End If
Set xlApp = Nothing
End Sub
I think this is maybe closer to what you need. Only need a single instance of excel for both workbooks...
Sub modExcel_SixMonth()
Const WB_PATH As String = "C:\Documents and Settings\Chris\Desktop\TestDir\"
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim xlRng As Excel.Range
Dim rCount As Long
Dim xlWB2 As Excel.Workbook
Dim xlWS2 As Excel.Worksheet
Dim xlRng2 As Excel.Range
Dim rCount2 As Long
Dim sFormula As String
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(WB_PATH & "acct 900860 Kentucky RSTS.xlsx")
Set xlWS = xlWB.Sheets(1)
Set xlWB2 = xlApp.Workbooks.Open(WB_PATH & "acct 900860 six months.xlsx")
Set xlWS2 = xlWB2.Sheets(1)
' rCount: RSTS Row Count
rCount = xlWS.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count - 1
Debug.Print "rCount : " & rCount
' rCount2: 6 Months Row Count
rCount2 = xlWS2.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count - 1
Debug.Print "rCount2 : " & rCount2
sFormula = "=VLOOKUP(C2," & xlWS2.Range("D2:D1937").Address(True, True, , True) & _
",1,FALSE)"
Debug.Print sFormula
With xlWS
.Range("D2").Formula = sFormula
End With
End Sub
Have you tried using the same application object? I believe this was a comment on this question earlier.
Additionally, if this doesn't work, you could use the find method of the range object. I.e.
XLWB2.Range("Your range here").find(XLWB1.Range( _
"Cell containing value you're looking for").Value,lookat:=xlwhole)