Grabbing a value from a cell in Excel and storing it in Access

[mastro78]

I currently have a table that stores the Excel file name(field:Spreadsheet) as well as the DateLastModified(fieldateModified). Now what I'd like to do is pull in the value from a single cell(cell:CntrlNm) in one of the worksheets(worksheetetails$) into that same table(table:Spreadsheets). Below is my code for the first step:

Private Sub Form_Open(Cancel As Integer)

'Set menu title
Dim dbs As Database, cnt As Container
Dim doc As Document, prp As Property, CapStr As String
Set dbs = CurrentDb ' Define Database object.
Set cnt = dbs.Containers!Databases ' Define Container object.
Set doc = cnt.Documents!SummaryInfo ' Define Document object.
CapStr = doc.Properties("Title")

'Prepare the database on opening the form
Dim Posst As DAO.Recordset
Dim savwks As String
Set Posst = CurrentDb.OpenRecordset("Spreadsheets", dbOpenTable)

'Delete contents of Spreadsheets Table
Do Until Posst.EOF
If Posst.Fields("Loaded") = -1 Then savwks = Posst.Fields("Spreadsheet")
Posst.Delete
Posst.MoveNext
Loop
'Read new Spreadsheets available
myname = Dir(CurrentDb.Name, vbNormal)
mypath = Left$(CurrentDb.Name, (Len(CurrentDb.Name) - Len(myname)))
'BeginTrans
myname = Dir(mypath + "*.XLS")
Do While myname <> "" ' Start the loop.
Posst.AddNew
Posst.Fields("Spreadsheet").Value = myname 'Set the filename
Posst.Fields("DateModified").Value = FileDateTime(mypath + myname) 'Set Date Modified
If myname = savwks Then Posst.Fields("Loaded") = -1
Posst.Update
myname = Dir ' Get next entry.
Loop
'CommitTrans
Posst.MoveLast
XLcnt = Posst.RecordCount
If XLcnt > 0 Then Me.Caption = CapStr & " with " & XLcnt & " spreadsheets"
If XLcnt = 0 Then
MsgBox "No Spreadsheets with data found."
Posst.Close
Quit
End If
'Close the recordset
Posst.Close
Call ImportFromExcel
End Sub

Please advise. I'm looking into all possible ways to extract the CntrlNm value associated to the Spreadsheet it is pulling from. Thank you in advance.

 

[SkipVought]

Hi,

Consider using a function. Here's a working example...

Function GetNbrRes(sResource As String)
    Dim sConn As String, sSQL As String
    Dim rst As ADODB.Recordset, cnn As ADODB.Connection
    Dim sPath As String, sDB As String
    Dim sPrevCC As String, BCC As Boolean
    
    sPath = "D:\My Documents\_Databases\_Excel"
    sDB = "ResourceData"
    
    Set cnn = New ADODB.Connection
    
    sConn = "Provider=MSDASQL.1;"
    sConn = sConn & "Persist Security Info=False;"
    sConn = sConn & "Extended Properties=""DSN=Excel Files;"
    sConn = sConn & "DBQ=" & sPath & "\" & sDB & ".xls;"
    sConn = sConn & "DefaultDir=" & sPath & ";"
    sConn = sConn & "DriverId=790;MaxBufferSize=2048;PageTimeout=5;"""
    
    cnn.Open sConn
    
    Set rst = New ADODB.Recordset
    
    sSQL = "SELECT ResCC "
    sSQL = sSQL & "FROM `" & sPath & "\" & sDB & "`.`ResourceData$` A "
    sSQL = sSQL & "WHERE Left(ResCC,1)='5' "
    sSQL = sSQL & "  AND Resource Like '%" & sResource & "%' "
    sSQL = sSQL & "Order By ResCC "
        
    With rst
        .Open sSQL, cnn, adOpenStatic, adLockReadOnly, adCmdText

        .MoveFirst
        sPrevCC = ""
        BCC = False
        Do Until (.EOF)
            If sPrevCC = rst(0) Then
                If Not BCC Then
                    BCC = True
                    GetNbrRes = GetNbrRes - 1
                End If
            Else
                BCC = False
            End If
            GetNbrRes = GetNbrRes + 1
            sPrevCC = rst(0)
            .MoveNext
        Loop
        .Close
    End With
    cnn.Close
    
    Set rst = Nothing
    Set cnn = Nothing
End Function

Skip,
[sub]
When a diminutive clarvoyant had disappeared from detention, headlines read...
Small Medium at Large[/sub]