Importing used range of sreadsheet into Access

[JimLes]

Okay, I found this code which works but I want to only import the spreadsheet data beginning on row 3 which contains the headers and continue through the used range. I tried using Offset(3,0) but no luck. Also, I would love to use a dialog box to find the file. If anyone could assist, I would greatly appreciate it.

Private Sub Command17_Click()
Dim strCurrProjPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Dim objWorksheet As Object 'Worksheet
Dim strXlFileName As String 'Excel Workbook name
Dim strWorksheetName As String 'Excel Worksheet name
Dim objCell As Object 'Last used cell in column
Dim strUsedRange As String 'Used range

'Path of current Access project
strCurrProjPath = Application.CurrentProject.Path

'Assign Path and filename of XL file to variable
strXlFileName = strCurrProjPath & "\" & "Test.xls"

'Assign Excel application to a variable
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False 'Can be visible or not visible

'Open the Excel Workbook
Set objWorkbook = objExcel.Workbooks.Open(strXlFileName)

'Assign required worksheet to a variable
With objWorkbook
Set objWorksheet = .Worksheets(1)
End With

With objWorksheet
'Assign worksheet name to a string variable
strWorksheetName = .Name

'Find last used cell in Column A
Set objCell = .Cells(.Rows.Count, "A").End(xlUp)

End With

'Assign used range to a string variable.
'.Address(0,0) returns A1:F10 type address.
'Absolute address ($A$1:$F$1000) does not work in
'DoCmd.TransferSpreadsheet.....etc.
strUsedRange = objWorksheet.UsedRange.Address(0, 0)
'Turn off/Close in reverse order to setting/opening.
Set objCell = Nothing
Set objWorksheet = Nothing

'SaveChanges = False suppresses save message
objWorkbook.Close SaveChanges:=True
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing

'Import the worksheet
DoCmd.TransferSpreadsheet acImport, 8, "tblAttendance_Data", _
strXlFileName, True, strWorksheetName & "!" & strUsedRange

End Sub

 

[PHV]

Why not using a named range ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[bubba100]

DoCmd.TransferSpreadsheet acImport, 8, "Table 1", "C:\MyFullPath\File Directory.xls", True, "Sheet1!a1:e400"
Use this as a guide.

 

[JimLes]

Thanks PHV, but the excel data is coming out of a database such as a time keeping system so the range will be dynamic with each import. Would a named range still work?

 

[JimLes]

The code I have above works and imports all of the used range in the spreadsheet. I just can't tweak it to start at row A3 and then get the used range. I tried deleting the first two rows when opening the spreadsheet but didn't have any luck.

Also, this code assumes the spreadsheet is in the current path and a static name. I used Text.xls as a working sample. I would like to incorporate a dialog box but not sure how to link it to this code. I do have code for the dialog box:

Dim filename As String

'Opens dialog box for file selection
Set ObjFSO = CreateObject("UserAccounts.CommonDialog")
'Sets Type of file to look for
ObjFSO.Filter = "Excel Files|*.xls|All Files|*.*"
ObjFSO.FilterIndex = 1


'Sets Directory for initial search to start in
ObjFSO.InitialDir = "C:\Your Location"
InitFSO = ObjFSO.ShowOpen

'Transfers file using acImportDelim profile previously set through manually importing into table
DoCmd.TransferText acImportDelim, ("Profile"), ("Temp_Tbl"), filename

End If

 

[JimLes]

Okay, I got the dialog box to work. Now I just need either delete the first two rows in my excel spreadsheet via VBA OR figure out a way to import the used range beginning with row 3. Here is the current working code:

Public Sub ImportAttendanceData()
Dim strCurrProjPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Dim objWorksheet As Object 'Worksheet
Dim strXlFileName As String 'Excel Workbook name
Dim strWorksheetName As String 'Excel Worksheet name
Dim objCell As Object 'Last used cell in column
Dim strUsedRange As String 'Used range
Dim FileName As String
Dim objDialog, boolResult

Set objDialog = CreateObject("UserAccounts.CommonDialog")

objDialog.Filter = "Excel Files|*.xls|All Files|*.*"
objDialog.FilterIndex = 1

boolResult = objDialog.ShowOpen

If boolResult = 0 Then
Exit Sub
Else
'MsgBox "The file you selected is: " & Mid(objDialog.FileName, InStrRev(objDialog.FileName, "\") + 1)
'MsgBox "The file you selected is: " & objDialog.FileName"


'Assign Path and filename of XL file to variable
strXlFileName = objDialog.FileName

'Assign Excel application to a variable
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False 'Can be visible or not visible

'Open the Excel Workbook
Set objWorkbook = objExcel.Workbooks.Open(strXlFileName)

'Assign required worksheet to a variable
With objWorkbook
Set objWorksheet = .Worksheets(1)
End With

With objWorksheet
'Assign worksheet name to a string variable
strWorksheetName = .Name

'Find last used cell in Column A
Set objCell = .Cells(.Rows.Count, "A").End(xlUp)

End With

'Assign used range to a string variable.
'.Address(0,0) returns A1:F10 type address.
'Absolute address ($A$1:$F$1000) does not work in
'DoCmd.TransferSpreadsheet.....etc.
strUsedRange = objWorksheet.UsedRange.Address(0, 0)
'Turn off/Close in reverse order to setting/opening.
Set objCell = Nothing
Set objWorksheet = Nothing

'SaveChanges = False suppresses save message
objWorkbook.Close SaveChanges:=True
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing

'Import the worksheet
DoCmd.TransferSpreadsheet acImport, 8, "tblAttendance_Data", _
strXlFileName, True, strWorksheetName & "!" & strUsedRange

End If
MsgBox "Attendance data imported successfully!"
End Sub

 

[PHV]

I just need either delete the first two rows
...
objWorksheet.Range("A1:A2").EntireRow.Delete
strUsedRange = objWorksheet.UsedRange.Address(0, 0)
...

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[JimLes]

Thanks PHV, that worked like a charm. For anyone who needs the code to use a dialog box and open an excel file to transfer to an access table using only the "used range" then here is the final product. You can remove the portion where it deletes the first two rows if your headers are on the first line.

Public Sub ImportFile()
Dim strCurrProjPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Dim objWorksheet As Object 'Worksheet
Dim strXlFileName As String 'Excel Workbook name
Dim strWorksheetName As String 'Excel Worksheet name
Dim objCell As Object 'Last used cell in column
Dim strUsedRange As String 'Used range
Dim FileName As String
Dim objDialog, boolResult

Set objDialog = CreateObject("UserAccounts.CommonDialog")

objDialog.Filter = "Excel Files|*.xls|All Files|*.*"
objDialog.FilterIndex = 1

boolResult = objDialog.ShowOpen

If boolResult = 0 Then
Exit Sub
Else

'Assign Path and filename of XL file to variable
strXlFileName = objDialog.FileName

'Assign Excel application to a variable
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False 'Can be visible or not visible
objExcel.UserControl = True

'Open the Excel Workbook
Set objWorkbook = objExcel.Workbooks.Open(strXlFileName)

'Assign required worksheet to a variable
With objWorkbook
Set objWorksheet = .Worksheets(1)
End With

With objWorksheet
'Assign worksheet name to a string variable
strWorksheetName = .Name

'Delete the first two rows in the spreadsheet down to Headers
objWorksheet.Range("A1:A2").EntireRow.Delete
'objExcel.Selection.Delete
objWorkbook.Save

'Find last used cell in Column A
Set objCell = .Cells(.Rows.Count, "A").End(xlUp)
End With

'Assign used range to a string variable.
strUsedRange = objWorksheet.UsedRange.Address(0, 0)
'Turn off/Close in reverse order to setting/opening.
Set objCell = Nothing
Set objWorksheet = Nothing

'SaveChanges = False suppresses save message
objWorkbook.Close SaveChanges:=False
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing

'Import the worksheet
DoCmd.TransferSpreadsheet acImport, 8, "tblAttendance_Data", _
strXlFileName, True, strWorksheetName & "!" & strUsedRange

End If
MsgBox "Attendance data imported successfully!"
End Sub