You could use Excel automation instead of FSO, here's an example I had which
reads an excel file that has a header and a section with a bunch of rows
(hope it is close enough that you can understand the example):
HTH
--
Mark Andrews
RPT Software
http://www.rptsoftware.com
http://www.donationmanagementsoftware.com
--------------------------------------------
Private Function ImportASingleWorksiteHazardSurvey(strfilename As String) As
Boolean
On Error GoTo Err_ImportASingleWorksiteHazardSurvey
'Use excel automation to open the excel file and retrieve values from cells
'end result is one new record in tblImportWorksiteHazardSurvey and multiple
records
' in tblImportWorksiteHazardSurveyLine
Dim objActiveWkb As Object
Dim objXL As Object
Dim Sheet As Object
Dim booXLCreated As Boolean
Dim rs As DAO.Recordset
Dim strSQL As String
Dim i As Integer
Dim LocationID As Long
Dim WorksiteHazardSurveyID As Long
Dim LastJobTitleOrTask As String
Dim LastRiskHazard As String
Dim result As Boolean
DoCmd.Hourglass True
result = False
' Get a instance of Excel that we can use
' If it's already open, use it.
' Otherwise, create an instance of Excel.
' I'm doing this by trying to use the Excel object.
' If it doesn't exist, an error will be raised, and
' that tells me to create an Excel instance.
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
' An error will be raised if Excel isn't already open.
If Err.Number = 0 Then
booXLCreated = False
Else
Set objXL = CreateObject("Excel.Application")
booXLCreated = True
End If
On Error GoTo Err_ImportASingleWorksiteHazardSurvey
'open an existing workbook (hopefully it is an excel "WORKSITE
HAZARD-RISK / SAFETY SURVEY" form with a certain format, otherwise you will
get errors)
Set objActiveWkb = objXL.Workbooks.Open(strfilename)
Set Sheet = objActiveWkb.Worksheets(1)
'Check first cell for heading to make sure it is the correct type of
form
If Sheet.Cells(8, 1).Value <> "WORKSITE HAZARD-RISK / SAFETY SURVEY"
Then
MsgBox ("Unable to import this file - it is not a 'WORKSITE
HAZARD-RISK / SAFETY SURVEY'.")
GoTo End_ImportASingleWorksiteHazardSurvey
End If
'Check for valid SiteNumber and save LocationID
LocationID = Nz(DLookup("LocationID", "tblLocation", "SiteCode = """ &
Sheet.Cells(2, 31).Value & """"), 0)
If (LocationID = 0) Then
MsgBox ("Unable to find a Location, based on SiteCode '" &
Sheet.Cells(2, 31).Value & "' in the database.")
GoTo End_ImportASingleWorksiteHazardSurvey
End If
'Check if location already has a record for this date
If DLookup("WorksiteHazardSurveyID", "tblWorksiteHazardSurvey",
"LocationID=" & LocationID & " AND AssessedByDate=#" & Sheet.Cells(33,
31).Value & "#") Then
If MsgBox("Location " & Sheet.Cells(4, 29).Value & " already has
data for " & Sheet.Cells(33, 31).Value & "." & vbCrLf _
& "Are you sure you want to import this form.", vbQuestion +
vbYesNo, "Worksite Hazard-Risk / Safety Survey Import") = vbNo Then GoTo
End_ImportASingleWorksiteHazardSurvey
End If
'retrieve values from excel file and populate variables
'Now we append a new record to tblWorksiteHazardSurvey
Set rs = CurrentDb.OpenRecordset("tblWorksiteHazardSurvey",
dbOpenDynaset)
rs.AddNew
'Note all Cell values are (ROW, COL)
rs("LocationID") = LocationID 'determine above
rs("Building") = Sheet.Cells(6, 29).Value
rs("AssessedBy") = Sheet.Cells(33, 1).Value
rs("AssessedBySignature") = Sheet.Cells(33, 16).Value
rs("AssessedByDate") = Sheet.Cells(33, 31).Value
rs.Update
'Get the last WorksiteHazardSurveyID that was added
rs.Bookmark = rs.LastModified
WorksiteHazardSurveyID = Nz(rs!WorksiteHazardSurveyID, 0)
rs.Close
If (WorksiteHazardSurveyID = 0) Then 'should never happen
MsgBox ("Unable to import this file - problem adding the header,
contact RPT Software for help.")
GoTo End_ImportASingleWorksiteHazardSurvey
End If
'special check for first row (must have both fields, otherwise we don't
append ANY rows)
If ((Nz(Sheet.Cells(12, 1).Value, "") = "") And (Nz(Sheet.Cells(12,
5).Value, "") = "")) Then
MsgBox ("Unable to import this file - there is NO detail lines
specified or the FIRST line has blanks in 'Job Title/Tas' and 'Risk
Hazard'.")
CurrentDb.Execute "DELETE * FROM tblWorksiteHazardSurvey where
WorksiteHazardSurveyID = " & WorksiteHazardSurveyID
GoTo End_ImportASingleWorksiteHazardSurvey
End If
'Now we append multiple records to tblWorksiteHazardSurveyLine
Set rs = CurrentDb.OpenRecordset("tblWorksiteHazardSurveyLine",
dbOpenDynaset)
For i = 12 To 28 'data on rows 12 thru 28
'if value in 'job title/task' or 'Risk Hazard' then add row
If ((Nz(Sheet.Cells(i, 1).Value, "") <> "") Or (Nz(Sheet.Cells(i,
5).Value, "") <> "")) Then
rs.AddNew
rs("WorksiteHarzardSurveyID") = WorksiteHazardSurveyID
'determine above
If (Nz(Sheet.Cells(i, 1).Value, "") = "") Then
rs("JobTitleOrTask") = LastJobTitleOrTask
Else
rs("JobTitleOrTask") = Sheet.Cells(i, 1).Value
LastJobTitleOrTask = Sheet.Cells(i, 1).Value
End If
If (Nz(Sheet.Cells(i, 5).Value, "") = "") Then
rs("RiskHazard") = LastJobTitleOrTask
Else
rs("RiskHazard") = Sheet.Cells(i, 5).Value
LastRiskHazard = Sheet.Cells(i, 5).Value
End If
rs("Head") = Sheet.Cells(i, 21).Value
rs("Foot") = Sheet.Cells(i, 23).Value
rs("Eye") = Sheet.Cells(i, 25).Value
rs("Hand") = Sheet.Cells(i, 27).Value
rs("Ear") = Sheet.Cells(i, 29).Value
rs("Resp") = Sheet.Cells(i, 31).Value
rs("Cover") = Sheet.Cells(i, 33).Value
rs("Other") = Sheet.Cells(i, 35).Value
rs.Update
End If
Next i
rs.Close
'Close the workbook
objActiveWkb.Close
result = True
End_ImportASingleWorksiteHazardSurvey:
On Error Resume Next
' Clean up after yourself!
Set objActiveWkb = Nothing
If booXLCreated Then
objXL.Application.Quit
End If
Set objXL = Nothing
Set rs = Nothing
DoCmd.Hourglass False
ImportASingleWorksiteHazardSurvey = result
Exit Function
Err_ImportASingleWorksiteHazardSurvey:
MsgBox Err.Number & ": " & Err.Description & " in
ImportASingleWorksiteHazardSurvey", _
vbOKOnly + vbCritical, "Error"
Resume End_ImportASingleWorksiteHazardSurvey
End Function
--------------------------------------------
mls via AccessMonster.com said:
I am reading an excel spreadsheet that has data starting from line 3 and
store it in Access 2007 database. It has coulmn names but they are not
relavant so I want to skip them and assign a different name. There are
around
250 columns so I am just trying to read a few columns to test my code.
I don't wan to use transferdb as there are format issues. Ex: Age has 6
mo.
as well numeric data so 6mo coming out missing.
My temp_str shows all junk character any idea?
Private Sub readxl()
Dim fso As New FileSystemObject
Dim Tst As TextStream
Dim strline As String
Dim strFilePath As String
Dim i As Integer
Dim Strfilename As String
' Access objects:
Dim objDB As DAO.Database
Dim mylog As DAO.Recordset
' Scripting Objects:
Dim objFSO As Scripting.FileSystemObject
DoCmd.RunSQL "Delete * from Demography;"
strFilePath = "temp\Study_test.xlsx"
i = 1
'Set ReportDb = CurrentDb
Set objDB = CurrentDb()
Set mydemo = objDB.OpenRecordset("Demography")
' Add a new record
If fso.FileExists(strFilePath) Then
Set Tst = fs
penTextFile(strFilePath, ForReading, False)
Do Until Tst.AtEndOfStream
strline = Tst.ReadLine
If (i > 3) Then
Dim Identifier As String
Dim Date_Recieved As Date
Dim Date_Collected As Date
Dim type As String
Dim Age As String
Dim Gender As String
temp_str = Mid(strline, InStr(strline, ":") + 1)
MyArray = Split(temp_str, ",")
mydemo.AddNew
mydemoIdentifier] = MyArray(0)
mydemo![Date_Recieved] = MyArray(1)
mydemo![Date_Collected] = MyArray(2)
mydemo![type] = MyArray(3)
mydemo.Update
End If
i = i + 1
Loop
Tst.Close
End If
mydemo.Close
End Sub
