CoolFactor
Technical User
The goal is to import excel data from the various columns in the worksheet knowingly that the first row is generally the column names in the worksheet. I created a table in Access with the columns that should match up with excel column names.
This is the part of the code that I'm having issues with and after this is the whole code:
rst("PEODirectorate") = ExcApp.Worksheets("Sheet1").Range("A2").Value
rst("Profile") = ExcApp.Worksheets("Sheet1").Range("B2").Value
rst("System") = ExcApp.Worksheets("Sheet1").Range("C2").Value
rst("Hull") = ExcApp.Worksheets("Sheet1").Range("D2").Value
rst("HullNumber") = ExcApp.Worksheets("Sheet1").Range("E2").Value
The Whole Code:
Option Compare Database
Private Sub cmdStar_Click()
On Error GoTo Err_cmdStar_Click
Dim NewRow As Integer
Dim R() As String
Dim InFile As String
Dim fileToOpen As String
Dim db As Database
Dim rst As Recordset
Dim SeqNum As Integer
Dim Continue As Boolean
Dim RowNum As Integer
Dim CellToRead As String
Dim Pos, LastPos, FileLen As Integer
Dim ExcApp As New Excel.Application
Dim newWBooks As Excel.Workbooks
Set newWBooks = ExcApp.Workbooks
'Dim myAcces As New Access.Application
Dim myFD As FileDialog
'Dim myFname As String
'Dim myFPath As String
Set myFD = FileDialog(msoFileDialogOpen)
myFD.Filters.Add "Excel Files", "*.xls", 1
myFD.AllowMultiSelect = False
With myFD
If .Show = -1 Then
fileToOpen = .SelectedItems.Item(1)
newWBooks.Open fileToOpen
'-1 = user selected open
' do what you will with newWB
Else
'! -1 = User canxed
MsgBox ("You must select an Excel Workbook to continue.")
GoTo NoSelection
End If
End With
StrLen = Len(fileToOpen)
Pos = InStr(1, fileToOpen, "\")
LastPos = Pos
If Pos > 0 Then
Do
Pos = Pos + 1
LastPos = InStr(Pos, fileToOpen, "\")
If LastPos <> 0 Then
Pos = LastPos
End If
Loop Until LastPos = 0
End If
InFile = Mid(fileToOpen, Pos)
Set db = CurrentDb
' first populate the primary table - holds the most-frequently used data
Set rst = db.OpenRecordset("tblcold")
rst.AddNew
' starts with the data in the sheet1 sheet
ExcApp.Worksheets("Sheet1").Activate
'Worksheets("Sheet1").Activate
rst("PEODirectorate") = ExcApp.Worksheets("Sheet1").Range("A2").Value
rst("Profile") = ExcApp.Worksheets("Sheet1").Range("B2").Value
rst("System") = ExcApp.Worksheets("Sheet1").Range("C2").Value
rst("Hull") = ExcApp.Worksheets("Sheet1").Range("D2").Value
rst("HullNumber") = ExcApp.Worksheets("Sheet1").Range("E2").Value
rst.Update
rst.Close
' and that's everything - we can close the database and the workbook!
'Set newWSs = Nothing
newWBooks.Close
Set newWBooks = Nothing
ExcApp.Quit
Set ExcApp = Nothing
db.Close
MsgBox "Excel Workbook Import Successfully Completed"
'
NoSelection:
Exit_cmdStar_Click:
Exit Sub
Err_cmdStar_Click:
MsgBox Err.Description
Set newWSs = Nothing
newWBooks.Close
Set newWBooks = Nothing
ExcApp.Quit
Set ExcApp = Nothing
db.Close
Resume Exit_cmdStar_Click
End Sub
This is the part of the code that I'm having issues with and after this is the whole code:
rst("PEODirectorate") = ExcApp.Worksheets("Sheet1").Range("A2").Value
rst("Profile") = ExcApp.Worksheets("Sheet1").Range("B2").Value
rst("System") = ExcApp.Worksheets("Sheet1").Range("C2").Value
rst("Hull") = ExcApp.Worksheets("Sheet1").Range("D2").Value
rst("HullNumber") = ExcApp.Worksheets("Sheet1").Range("E2").Value
The Whole Code:
Option Compare Database
Private Sub cmdStar_Click()
On Error GoTo Err_cmdStar_Click
Dim NewRow As Integer
Dim R() As String
Dim InFile As String
Dim fileToOpen As String
Dim db As Database
Dim rst As Recordset
Dim SeqNum As Integer
Dim Continue As Boolean
Dim RowNum As Integer
Dim CellToRead As String
Dim Pos, LastPos, FileLen As Integer
Dim ExcApp As New Excel.Application
Dim newWBooks As Excel.Workbooks
Set newWBooks = ExcApp.Workbooks
'Dim myAcces As New Access.Application
Dim myFD As FileDialog
'Dim myFname As String
'Dim myFPath As String
Set myFD = FileDialog(msoFileDialogOpen)
myFD.Filters.Add "Excel Files", "*.xls", 1
myFD.AllowMultiSelect = False
With myFD
If .Show = -1 Then
fileToOpen = .SelectedItems.Item(1)
newWBooks.Open fileToOpen
'-1 = user selected open
' do what you will with newWB
Else
'! -1 = User canxed
MsgBox ("You must select an Excel Workbook to continue.")
GoTo NoSelection
End If
End With
StrLen = Len(fileToOpen)
Pos = InStr(1, fileToOpen, "\")
LastPos = Pos
If Pos > 0 Then
Do
Pos = Pos + 1
LastPos = InStr(Pos, fileToOpen, "\")
If LastPos <> 0 Then
Pos = LastPos
End If
Loop Until LastPos = 0
End If
InFile = Mid(fileToOpen, Pos)
Set db = CurrentDb
' first populate the primary table - holds the most-frequently used data
Set rst = db.OpenRecordset("tblcold")
rst.AddNew
' starts with the data in the sheet1 sheet
ExcApp.Worksheets("Sheet1").Activate
'Worksheets("Sheet1").Activate
rst("PEODirectorate") = ExcApp.Worksheets("Sheet1").Range("A2").Value
rst("Profile") = ExcApp.Worksheets("Sheet1").Range("B2").Value
rst("System") = ExcApp.Worksheets("Sheet1").Range("C2").Value
rst("Hull") = ExcApp.Worksheets("Sheet1").Range("D2").Value
rst("HullNumber") = ExcApp.Worksheets("Sheet1").Range("E2").Value
rst.Update
rst.Close
' and that's everything - we can close the database and the workbook!
'Set newWSs = Nothing
newWBooks.Close
Set newWBooks = Nothing
ExcApp.Quit
Set ExcApp = Nothing
db.Close
MsgBox "Excel Workbook Import Successfully Completed"
'
NoSelection:
Exit_cmdStar_Click:
Exit Sub
Err_cmdStar_Click:
MsgBox Err.Description
Set newWSs = Nothing
newWBooks.Close
Set newWBooks = Nothing
ExcApp.Quit
Set ExcApp = Nothing
db.Close
Resume Exit_cmdStar_Click
End Sub