Allow Access user to select Excel worksheet for linking - excel

So I am using VBA in Access to create linked tables between Excel and Access. Simple enough and as some online resources guided me I decided to utilize the TransferSpreadsheet command. So I ran some code to test out if I had the syntax correct and got this
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12, _
"Link Name", "File Path", True, "Sheet Name!"
So that worked perfectly, but I wanted to automate it so someone who doesn't understand how to code can use the function. So for the file path I set up a file dialog box to come up so the user can select the excel file. Again worked great.
So now to the point, I want to create a dialog box for users to select the excel sheet to link as well. So essentially the user would select the excel file first and then select from a drop down box the sheet they want to link. Is this possible? If so how would I go about doing it. Here is my code so far:
Public Sub linksheet()
Dim fd As FileDialog
Dim strpath As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
fd.Title = "Select Routing File"
'get the number of the button chosen
Dim FileChosen As Integer
FileChosen = fd.Show
If FileChosen <> -1 Then
Else
strpath = fd.SelectedItems(1)
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12, _
"Test Link", strpath, True, "Current!"
End If
End Sub
To add to this further I was attempting to utilize this code I found to get the names but I'm unsure how to store them as variables to use.
Public Function WorkSheetNames(strwspath As String) As Boolean
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim strarray(25)
Set xlApp = CreateObject("Excel.application")
Set xlBook = xlApp.Workbooks.Open(strwspath, 0, True)
For Each xlSheet In xlBook.Worksheets
Debug.Print xlSheet.Name
Next xlSheet
xlBook.Close False
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Set xlSheet = Nothing
End Function
What the above code does is list out each sheet name into the debug window, I just am finding it difficult to push those values to an array.

I don't see why you need to store the sheet names in an array. You could store them as a list in a string variable. Then you could assign that string as the RowSource property of a combo box which allows the user to select one of the available sheets.
Dim strSheets As String
' adapt your existing code to use this ...
For Each xlSheet In xlBook.Worksheets
'Debug.Print xlSheet.Name
strSheets = strSheets & ";" & xlSheet.Name
Next xlSheet
' discard leading semi-colon
strSheets = Mid(strSheets, 2)
After you have collected the sheet names, apply them as the combo box source.
' ComboName should have Value List as Row Source Type
Me.ComboName.RowSource = strSheets

Related

MS Access Directory check and create using declared variable

I have appended a code I tested to copy and paste some data to Excel. i want to do 1) Check if directory exists 2) if it doesn't create it 3) if it does, display message box and stop the sub
Dim excelapp As Excel.Application
Dim wbTarget As Excel.Workbook
Dim qdfquerytest As QueryDef
Dim rsquerytest As Recordset
Set qdfquerytest = CurrentDb.QueryDefs("OpenComplaintsQuery") 'which query to define
Set rsquerytest = qdfquerytest.OpenRecordset() 'which recordset to open
Set excelapp = CreateObject("Excel.Application") 'create an Excel instance
excelapp.Visible = True 'Make Excel visible
If Len(Dir("O:\1_All Customers\Current Complaints\Complaint Folders\" &
rsquerytest(1).Value)) = 0 Then
MkDir "O:\1_All Customers\Current Complaints\Complaint Folders\ &
rsquerytest(1).Value"
Else
MsgBox "Folder already exists!", vbOKOnly
Exit Sub
End If
When i run i get runtime 75 error about file path isn't valid. I am pretty sure if the way i have the directory typed out to include rsquerytest(1) which is a serial number in the record. Additionally despite the error the code continues to run should i have put the If statement BEFORE setting Excel app?
Editting Post to post Code that is working
Private Sub cmdcopyfieldsonly_Click()
'This function works
'Things to add Checking for directory usage, Create the
directory, Stopping if directory is found and msg box,
'Declare and set excel objects and target data
Dim excelapp As Excel.Application
Dim wbTarget As Excel.Workbook
Dim qimsnum As Variant
Dim rsquerytest As Recordset
Set rsquerytest =
CurrentDb().OpenRecordset("OpenComplaintsQuery") 'which
recordset to open
Set qimsnum = Me.[QIMS#]
Dim savepath As String
Dim openpath As String
savepath = "Redacted filepath"
openpath = "Redacted Filepath"
'Set excelapp = CreateObject("Excel.Application") 'create an
Excel instance
'excelapp.Visible = True 'Make Excel visible
If Len(Dir(savepath & Me.[QIMS#], vbDirectory)) = 0 Then
MkDir savepath & Me.[QIMS#]
Else
MsgBox "Folder already exists!", vbOKOnly
Exit Sub
End If
I did leave portions after the If out as it does not pertain to this issue, June7 should have listened to you the first time i believe in a previous post you helped me with, I couldn't wrap my brain around it. and i am well aware this code can be cleaned up further ;), i am just working out the basic functions and will clean it up from there. Thank you for you support!

Excel keep getting locked from ms access vba code

I am trying to export excel from ms access vba code. I am able to do most of the part except couple of problems.
1) The excel application keep getting locked and when i try to open spreadsheet it says spreadsheet locked for editing by myself. I have released all the variables at the end as well but still no luck.
2) I am not able to open the new "Saved As" spreadsheet automatically and also need to close the original spreadsheet.
I searched extensively on google and went through other questions on stackoverflow but could not figure it out.
Requirement - I want to export excel from ms access. I need take the existing spreadsheet, replace its contents when my code runs and then save as to another worksheet keeping original spreadsheet unchanged. I need to also open the new spreadsheet and present to the user. Here is my code:
Private Sub GenerateReport(strFileName As String)
Set xlObj = CreateObject("Excel.Application")
Dim xlWB As Workbook
Dim xlSheet As Worksheet
Dim fpath As String
Dim path As String
Dim fname As String
With xlObj
On Error goto errorHandler
.DisplayAlerts=False
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "tableName", strFileName, True
Set xlWB = Workbooks.Open(strFileName) 'strFileName consist of full path of spreadsheet
xlWB.Activate
fdate = "20200521"
path = xlWB.path
' Some code for formatting excel spreadsheet
fname = "Temp" & fdate
xlWB.SaveAs Filename:=path & "\" & fname, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Set xlWB = Nothing
Set xlObj = Nothing
procdone:
Set xlWB = Nothing
Set xlObj = Nothing
Exit Sub
errorHandler:
Resume procdone
End With
End Sub

Error with transferspreadsheet command

Attempting to import data from Excel file (vrtSelectedItem) to Access table (MAF), but receive "Type Mismatch" error on the DoCmd line.
The data is in a sheet named "For Export", but I'm not sure I indicated that correctly. Could be something else on the line, though.
Additionally, the data is in a named range, "ExportRange". Is it possible to use the name instead of specifying the cells?
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim xl As Object
Dim wb As Object, ws As Object
'Dim data1 As Variant
'Select Excel file
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.AllowMultiSelect = True
.Title = "Select one or more files"
.InitialFileName = InitPath
If .Show = True Then
Set xl = CreateObject("excel.application")
For Each vrtSelectedItem In .SelectedItems
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, MAF, vrtSelectedItem("For Export"), 0, "B1:B72"
Next
End If
End With
If the data you want to import is in a named range ("ExportRange"), use that name as the Range argument. And in that case, don't even mention the sheet name.
The TableName argument should be a string value. I assumed you want to import the data into a table named "MAF", so quoted that table name.
DoCmd.TransferSpreadsheet TransferType:=acImport, _
SpreadsheetType:=acSpreadsheetTypeExcel9, _
TableName:="MAF", _
FileName:=vrtSelectedItem, _
HasFieldNames:=False, _
Range:="ExportRange"
I don't see the value of CreateObject("excel.application"). It seems you only need a straightforward TransferSpreadsheet operation so you shouldn't need to create Excel application instances.

Importing multiple sheets from an excel file into multiple tables by sheet name

Hi there and thanks for your help. I'm putting together a seemingly simple Access data management solution for use in our office here and I'm having trouble as my background in vba is minimal at best.
What I have here are two related but disconnected Access 2007 applications and I need a system for the user to easily import and export this information. I've got a script working now to export all the tables from the application into a single excel file with each table as a different worksheet, the issue is that when I go to import it only seems to find the first sheet for import.
What I'm hoping to find is a method to iterate over each worksheet, grab the sheet name, and then merge that data into the table based on the sheet name.
To clarify:
Multiple copies of App A are sent to various departments
App A: Users enter information into the tables
App A: Users press command to run export macro
Excel file is created with each table as a sheet with matching names (e.g. tblCourse, tblStudent, tblFaculty, etc.)
Users of App B receive excel spreadsheet
App B: Users press command to run import script (This is the solution I'm looking for)
User is prompted for file location
Import script opens excel workbook
Script iterates over each sheet, reads name, and imports data to table of matching name
Thanks in advance for any help you can provide, much appreciated.
Edit
Working script (Thanks greatly to grahamj42's help here):
Private Sub Command101_Click()
'Dim excelapp As New Excel.Application
Dim excelApp As Object
Set excelApp = CreateObject("Excel.Application")
'Dim excelbook As New Excel.Workbook
Dim excelbook As Object
Set excelbook = excelApp.Workbooks.Add
'Dim excelsheet As New Excel.Worksheet
'Dim excelsheet As Object
'Set excelsheet = excelbook.Sheets
Dim intNoOfSheets As Integer, intCounter As Integer
Dim strFilePath As String, strLastDataColumn As String
Dim strLastDataRow As String, strLastDataCell As String
strFilePath = "C:\Users\UserName\Documents\Export\DatabaseExport03-28-2013.xlsx"
Set excelbook = excelApp.Workbooks.Open(strFilePath)
intNoOfSheets = excelbook.worksheets.Count
Dim CurrSheetName As String
For intCounter = 1 To intNoOfSheets
excelbook.worksheets(intCounter).Activate
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, ActiveSheet.Name, _
strFilePath, True, _
excelbook.Worksheets(intCounter).Name & "!" & _
Replace(excelbook.Worksheets(intCounter).UsedRange.Address, "$", "")
Next
excelbook.Close
excelApp.Quit
Set excelApp = Nothing
End Sub
Note that in the DoCmd.TransferSpreadsheet command there is a HasFieldNames property that is set to 'True' here because my spreadsheets export with the field names as column headers.
Your use of Selection without selecting anything will refer to the selected cell in the worksheet when it was saved. While I don't see, in your case, why this should be outside the table, you could do better like this without selecting anything by using Worksheet.UsedRange:
For intCounter = 1 To intNoOfSheets
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, Activesheet.Name, _
strFilePath, True, _
excelbook.Worksheets(intCounter).Name & "!" & _
Replace(excelbook.Worksheets(intcounter).UsedRange.Address, "$", "")
Next
I did a little combining of two different pieces of code, as I didn't want to hard code the location or file name.
Dim excelApp As Object
Dim excelbook As Object
Dim dlg As FileDialog
Dim StrFileName As String, intcounter, intNoOfSheets As Integer
Set excelApp = CreateObject("Excel.Application")
Set dlg = Application.FileDialog(msoFileDialogFilePicker)
With dlg
.Title = "Select the Excel file to import"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx", 1
.Filters.Add "All Files", "*.*", 2
If .Show = -1 Then
StrFileName = .SelectedItems(1)
Set excelbook = excelApp.Workbooks.Open(StrFileName)
intNoOfSheets = excelbook.worksheets.Count
'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "COR Daily", StrFileName, True
For intcounter = 1 To intNoOfSheets
excelbook.worksheets(intcounter).Activate
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, excelbook.Activesheet.Name, StrFileName, True, _
excelbook.worksheets(intcounter).Name & "!" & _
Replace(excelbook.worksheets(intcounter).UsedRange.Address, "$", "")
Next
Else
Exit Function
End If
End With
End Function

Issue in importing excel data in access if worksheet contains dropdown list

I have created an excel worksheet in a such way that the user can insert some rows (max 100).
The value of some fields are chosen from a dropdown list.
I put the formula on all 100 rows.
The problem is that the data are not imported in access, if the user inserts less of 100 rows. In this case the data are imported only if I delete the formula for the dropdown list from the remaining rows.
To import excel data in access I use:
DoCmd.TransferSpreadsheet [Transfer Type], [Spreadsheet Type], [Table Name], [File Name], [Has Field Names], [Range]
How could I resolve this issue?
EDIT
After the Remou's answer, I tried with:
Private Sub import_Click()
Dim openDialog As FileDialog
Dim FileChosen As Integer
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
On Error GoTo DoNothing
With openDialog
.title = "Import"
.AllowMultiSelect = False
.Show
End With
filename = openDialog.SelectedItems.Item(1)
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim rng As Excel.Range
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set wb = xl.Workbooks.Open(nomeFile)
c = wb.Worksheets("Sheet1").Range("1:1").end(-4161).Address
r = wb.Worksheets("Sheet1").Range("A:A").end(-4121).Row
ImportRange = "Sheet1!" & "A1:" _
& Replace(Mid(c, 1, InStrRev(c, "$")) & r, "$", "")
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, _
"ImportTable", filename, True, ImportRange
DoNothing:
If Err.Number = cdlCANCEL Then
End If
End Sub
but I've a debug error on Dim xl As Excel.Application
NOTE Having tested with Excel dropdowns and validation dropdowns, I find I do not have any problems importing data with validated cells or dropdowns in unused ranges, other than those rows are imported, even though all other cells are empty. The problem may be with data types and importing into an existing table. You may have to import to a scratch table and then append.
I suggest you use automation to get the used range and add that as the range to import.
This sample code uses late binding. You can add a reference to the Microsoft Excel x.x Object Library, so I have kept the various definitions, but late binding is best if you are using the code on more than one PC.
Dim xl As Object ''Excel.Application
Dim wb As Object ''Excel.Workbook
Dim rng As Object ''Excel.Range
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set wb = xl.Workbooks.Open("z:\docs\test.xlsx")
'Choosing a column that is fully filled on sheet5
'xldown=-4121,xltoright=-4161
c = wb.Worksheets("Sheet5").Range("1:1").end(-4161).Address
r = wb.Worksheets("Sheet5").Range("A:A").end(-4121).Row
ImportRange = "Sheet5!" & "A1:" _
& Replace(Mid(c, 1, InStrRev(c, "$")) & r, "$", "")
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, _
"ImportSheet2", "Z:\Docs\csharp.xlsm", True, ImportRange

Resources