I want to substitute the hard codes between the 2 underlined area in VB as indicated, so that it fetches the excel file automatically with code and transfers the spreadsheet into an Ms-Access table with same fields. IT should be able to do this function automatically with vb codes in MS-Access.
Dim fso As Object 'FileSystemObject
Dim f As Object 'File
Dim strTempPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Const TemporaryFolder = 2
On Error Resume Next
StrSQL = "DELETE * FROM bed_code_tbl"
DoCmd.SetWarnings False
DoCmd.RunSQL StrSQL
Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
strTempPath = fso.GetSpecialFolder(TemporaryFolder) & "\" & fso.GetTempName & "\"
fso.CreateFolder strTempPath
'------------------------------------------------------
Set f = fso.GetFile("C:\Users\johnpfe\Documents\Bed_code_tbl.xlsx")
fso.CopyFile f.Path, strTempPath & f.Name
'--------------------------------------------------------
Set objExcel = CreateObject("Excel.Application") ' New Excel.Application
Set objWorkbook = objExcel.Workbooks.Open(strTempPath & f.Name)
objWorkbook.ActiveSheet.Range("A1:C100").Select
objWorkbook.Save
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "bed_code_tbl",
strTempPath & f.Name, True
fso.DeleteFile strTempPath & f.Name
fso.DeleteFolder Left(strTempPath, Len(strTempPath) - 1)
Set f = Nothing
Set fso = Nothing
End Sub
'----------------------------------------------------------------------
I'm assuming that you're trying to find the current user's documents folder.
You can use the eviron() function. More on that if you follow these links.
http://msdn.microsoft.com/en-us/library/office/gg264486(v=office.15).aspx
http://www.tek-tips.com/faqs.cfm?fid=4296
Dim fso As Object 'FileSystemObject
Dim f As Object 'File
Dim strTempPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Const TemporaryFolder = 2
On Error Resume Next
strSQL = "DELETE * FROM bed_code_tbl"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
strTempPath = fso.GetSpecialFolder(TemporaryFolder) & "\" & fso.GetTempName & "\"
fso.CreateFolder strTempPath
'------------------------------------------------------
Set f = fso.GetFile(Environ("UserProfile") & "\Documents\Bed_code_tbl.xlsx")
fso.CopyFile f.Path, strTempPath & f.NAME
'----------------------------------------------------------------------
You can get folder location for Your access file. And place created file relative to that location.
Alternatively ask user for the location.
Related
I get a Method Range of Object _Global failed error due to the following code
SOMETIMES this code works SOMETIMES it doesnt. I understand the cause of it but not how to fix it. How do i specify which sheet this is selecting everytime so that it works consistently.
'Fill Formulas'
Range(columnLetter & "5").Select
Selection.AutoFill Destination:=Range(columnLetter & "5:" & columnLetter & "113"), Type:=xlFillDefault
Range(columnLetter & "143").Select
Selection.AutoFill Destination:=Range(columnLetter & "143:" & columnLetter & "251"), Type:=xlFillDefault
Here is all of my code
Public Sub AutoUpdateCancels()
Dim MySheetPath As String
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim formattedDate As String
Dim lngRow As Long, intCol As Integer, db As DAO.Database, rst As DAO.Recordset, fld As DAO.Field
Dim columnLetter As String
Dim qdf As DAO.QueryDef
columnLetter = DLookup("[Column]", "[tblColumnIdentifier17]", "[WED] like #" & [Forms]![frmCancelsReporting]![txtCancelsWED] & "#")
formattedDate = Format(Date, "mm-dd-yyyy")
MySheetPath = "M:\Chris\Weekly Pulse\Cancel Report\2018\COM\Cancels Report - 2018v2.xlsx"
'Open Excel and the workbook and save a backup
Set Xl = CreateObject("Excel.Application")
Set XlBook = Xl.Workbooks.Open(MySheetPath, True)
Xl.Visible = True
XlBook.Windows(1).Visible = True
Set XlSheet = XlBook.Worksheets(11)
'Xl.ActiveWorkbook.SaveAs FileName:="M:\Chris\Weekly Pulse\Cancel Report\Backups\COM Backup 03-12-2018.xlsx"
'Clear Detail'
Xl.Range("A256:D371").Select
Xl.Selection.ClearContents
'Starting Row Number'
lngRow = 256
'Append New Detail'
Set db = CurrentDb
Set qdf = db.QueryDefs("qryCancelsReport")
qdf.Parameters("EndDate").Value = [Forms]![frmCancelsReporting]![txtCancelsWED]
Set rst = qdf.OpenRecordset()
Xl.Cells(lngRow, 1).CopyFromRecordset rst
'Fill Formulas'
Range(columnLetter & "5").Select
Selection.AutoFill Destination:=Range(columnLetter & "5:" & columnLetter & "113"), Type:=xlFillDefault
Range(columnLetter & "143").Select
Selection.AutoFill Destination:=Range(columnLetter & "143:" & columnLetter & "251"), Type:=xlFillDefault
Set rst = Nothing
Set db = Nothing
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
MsgBox ("Make sure to save over original worksheet not as backup")
End Sub
You were not referencing proper objects (e.g.: you used Xl.Range() instead of xlSheet.Range())
Avoid using Select/Selection/Activate/ActiveXXX coding pattern an use fully qualified range references (e.g. use xlSheet.Range() instead of Range())
So try this snippet:
With XlBook.Worksheets(11) ‘reference wanted sheet. From now on and till next ‘End With’ all referenced sheet members (like its Range()) are just a dot (.) away:
'Clear Detail'
.Range("A256:D371").ClearContents
'Starting Row Number'
lngRow = 256
'Append New
....
.Cells(lngRow, 1).CopyFromRecordset rst
'Fill Formulas'
.Range(columnLetter & "5").AutoFill Destination:=.Range(columnLetter & "5:" & columnLetter & "113"), Type:=xlFillDefault
.Range(columnLetter & "143").AutoFill Destination:=.Range(columnLetter & "143:" & columnLetter & "251"), Type:=xlFillDefault
End With
I have the below code working for me provided the "Model_data.xlsm" file is stored in my hard drive. Is it possible if Access can get the data from "model_data.xlsm" stored in Sharepoint?
Private Sub Update_manu_data_Click()
Dim strXls As String
strXls = CurrentProject.Path & Chr(92) & "Model_data.xlsm"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Manufacturing_data", _
strXls, True, "Combined!"
End Sub
Finally I did find a workaround for this issue.
I Created a private function in access to download the Excel file from SP and then used the Transferspread sheet function to retrieve the data into access table.
Below is the code i used to download the Excel file in SP using access Vba
Private Sub Command2_Click()
Dim Ex As Object
Dim Acc As Object
Dim strXls As String
Set Ex = CreateObject("Excel.Application")
Set Acc = Ex.Workbooks.Open("https://Sharepoint File link")
Ex.Visible = False
Acc.SaveAs "C:\Users\.......\test.xlsx"
Acc.Close
Ex.Quit
strXls = CurrentProject.Path & Chr(92) & "C:\Users\.......\test.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Tablename", _
strXls, True, "Sheet(1)!"
End Sub
Sub ConnectToExcel()
Dim strSharePointPath As String
Dim strExcelPath As String
Dim strConnectionString As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
' Set the SharePoint path and Excel file name
strSharePointPath = "http://yoursharepointurl.com/YourSharePointFolder/"
strExcelPath = "YourExcelFile.xlsx"
' Build the connection string
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"WSS;IMEX=0;RetrieveIds=Yes;" & _
"DATABASE=" & strSharePointPath & ";" & _
"LIST=" & strExcelPath & ";"
' Open the connection
Set cnn = New ADODB.Connection
cnn.Open strConnectionString
' Open a recordset
Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM [Sheet1$]", cnn
' Loop through the recordset and display the data
Do While Not rs.EOF
Debug.Print rs.Fields(0).Value
rs.MoveNext
Loop
' Clean up
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
End Sub
I am using the code for listing files in a folder.
Dim fso
Dim ObjOutFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ObjOutFile = fso.CreateTextFile(GetFiles(FolderName) & "_"&"OutputFiles.csv")
ObjOutFile.WriteLine("Type,File Name,File Path")
GetFiles("YOUR LOCATION")
ObjOutFile.Close
WScript.Echo("Completed")
Function GetFiles(FolderName)
On Error Resume Next
Dim ObjFolder
Dim ObjSubFolders
Dim ObjSubFolder
Dim ObjFiles
Dim ObjFile
Set ObjFolder = fso.GetFolder(FolderName)
Set ObjFiles = ObjFolder.Files
For Each ObjFile In ObjFiles
ObjOutFile.WriteLine("File," & ObjFile.Name & "," & ObjFile.Path)
Next
Set ObjSubFolders = ObjFolder.SubFolders
For Each ObjFolder In ObjSubFolders
ObjOutFile.WriteLine("Folder," & ObjFolder.Name & "," & ObjFolder.Path)
GetFiles(ObjFolder.Path)
Next
End Function
I am getting Output as _OutputFiles.csv
If I run the script in a folder I want the output as
New Folder (3)_OutputFiles.csv
New Folder (2)_OutputFiles.csv
with all files listed.
Please suggest how to implement such that I get output for each parent folder separately.
You have to move your definition of the output file AFTER you obtain the parent folder name, and include the .Name attribute of the folder.
Dim fso
Dim ObjOutFile
Set fso = CreateObject("Scripting.FileSystemObject")
GetFiles("YOUR LOCATION")
ObjOutFile.Close
WScript.Echo("Completed")
Function GetFiles(FolderName)
On Error Resume Next
Dim ObjFolder
Dim ObjSubFolders
Dim ObjSubFolder
Dim ObjFiles
Dim ObjFile
Set ObjFolder = fso.GetFolder(FolderName)
Set ObjOutFile = fso.CreateTextFile(GetFiles(FolderName.Name) & "_"&"OutputFiles.csv")
ObjOutFile.WriteLine("Type,File Name,File Path")
Set ObjFiles = ObjFolder.Files
For Each ObjFile In ObjFiles
ObjOutFile.WriteLine("File," & ObjFile.Name & "," & ObjFile.Path)
Next
Set ObjSubFolders = ObjFolder.SubFolders
For Each ObjFolder In ObjSubFolders
ObjOutFile.WriteLine("Folder," & ObjFolder.Name & "," & ObjFolder.Path)
GetFiles(ObjFolder.Path)
Next
End Function
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
Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
qdf.Parameters("fileName") = strFile
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub
As you can see from the code on import I want to store the file name and while it does work it doesn't work exactly how I need it to. When we do work for this client it is 5 files ate a time once a week so I would like it to save all 5 file names however it only saves the last one it imports. My question, is there a way to save each file name to each one ( I doubt that) or can I save all 5 file names to all the records I import instead of just the last file name?
I always have the option of only allowing a single import and making them import and append the table 5 times I just wanted to check to see if there is a more efficent way before doing so.
Thanks in advance for any help in this matter!
There is a problem in your logic. Inside the loop, strFile holds the current file name. So after your loop is finished, only the current (=last) file name is passed on to the query.
I made some changes, so the filenames are now stored in the new variable strFileList, delimited by a ";". Please check, if this is a feasible solution.
Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
' Variable to hold file list
Dim strFileList As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
'Add file name to file list
strFileList = strFileList & strFile & ";"
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
'Pass file list to query
qdf.Parameters("fileName") = strFileList
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub