CHAOSinACT
09-12-2010, 03:19 PM
i've linked data from excel spreadsheets often to my database; wondering if there is any way to pause for user input? i need to open the sheet and have the user select a cell or 2; the spreadsheets are dynamic and no way to predict which cell the data will be in.
GalaxiomAtHome
09-13-2010, 05:00 AM
You code would first open the spreadsheet and prompt the user to select the cells. The selection information would be stored in variables.
Then you run the import using the information as required.
CHAOSinACT
09-13-2010, 02:34 PM
i'm just not familiar with the excel event model to know exactly how to get it to "pass" back those variables.... any good web sites you would recommend?
chergh
09-14-2010, 08:50 AM
It depends what you want to pass back and to what.
Are your users just highlighting a few cells and you want to pass back the value in each cell?
Do cells need to be done in a specific order?
Are you over writing existing data in the spreadsheet?
You've not given us much to go. If you provide more information about what you want to do we can give better answers.
CHAOSinACT
09-14-2010, 02:26 PM
fair enough; to be honest I'm not positive how it will work. i'm trying hard to figure out ways to do what we need. tragically i've come to accept that we simply HAVE to pause the program and let the user do his thing in excel (its a claim sheet) and the problem is each one is unique...
i need to be able to summarize what they have done and bring the totals back to access. there is no way to know which cell it will be in, i think they user will have to select the cells to tell the access application but how i fire an excel event within access i'm not sure. i've pushed and pulled data out of cells no problems but events over there from here? no idea....
wiklendt
10-20-2010, 06:07 PM
CHAOSinACT, don't really know what your intent is with the spreadsheet, but sounds like you're linking it for no reason? You *just* want a couple of cells' worth of values?
However, that being said: you're doing sounds similar to what i'm currently working on.
I've had quite a bit of progress, see if you can see anything useful in my code and feel free to use any of it. (Some was provided by others here (http://www.access-programmers.co.uk/forums/showthread.php?t=199935&highlight=select+cells+excel&page=2)).
What this code does currently: opens an existing workbook; adds an additional worksheet and adds headers and formulae; finds data in the existing (original) sheet using a "For" loopy thing - that is, finds a "label" cell (a cell whose value doesn't change, but location in the sheet might, and i know is next to the data i want), finds the cell next to it, and grabs the value, puts it into a declared string.
I'm still developing and testing it, so don't take it as gospel! Here it is, i've highlighted in red about 5 bits throughout, which i think you will find most useful, but don't forget to declare all your objects and string variables!
Option Compare Database
Function fImportPhoenix() As String
On Error GoTo Err_fImportPhoenix
Dim i As Long
Dim Msg As String
Dim fld As Field
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
' ====== OPEN WORKBOOK AND SHEET ================================================ '
' Notes: WORKING
Dim strDialogTitle As String
Dim strPath As String
strDialogTitle = "Select a file for import"
strPath = GetOpenFile_CLT(".\", strDialogTitle) ' just a generic file dialog
'If no file was selected then the PathStrg variable will be empty.
'If there was a file selected then.....
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim Range As Object
If strPath <> "" Then
Set ApXL = CreateObject("Excel.Application") 'invoke excel application
Set xlWBk = ApXL.Workbooks.Open(strPath) 'open the selected file
Set xlWSh = xlWBk.Worksheets("Sheet1")
ApXL.Visible = True ' don't show the file to the user
' ====== ADD NEW WORKSHEETS ================================================== === '
' Notes: DEVELOPING, but all WORKING unless otherwise stated
Dim xlWShExtract As Object
Dim xlWShMarkers As Object
Dim xlWShExRules As Object
' check if additional worksheets exists, if not create them
On Error Resume Next
Set xlWShExtract = xlWBk.Sheets("Extract")
Set xlWShMarkers = xlWBk.Sheets("Markers") ' this one yet to code
Set xlWShExRules = xlWBk.Sheets("ExRules") ' this one yet to code
On Error GoTo Err_fImportPhoenix
' ------ "EXTRACT" Results Extraction Worksheet ------------------------- '
' this worksheet will be used for importing into a temporary Access table
If Not xlWShExtract Is Nothing Then
'sheet has already been generated
'(and thus imported, once i finish the code!, so exit for this file)
'maybe check that the record exists...?
'and/or ask if user wants to re-import? overwrite? etc...
'End Function
Else
'does not exist, so add it
ApXL.Worksheets.Add.Move After:=ApXL.Worksheets(ApXL.Worksheets.Count)
ApXL.Sheets(ApXL.Worksheets.Count).Name = "Extract"
Set xlWShExtract = xlWBk.Sheets("Extract")
'and add appropariate headers
With xlWShExtract
.Range("A1") = "Antimicrobial"
.Range("B1") = "Qualifier"
.Range("C1") = "Value"
.Range("D1") = "SIR"
.Range("E1") = "Reading"
End With
'copy over information from Sheet1.
With xlWSh
.Activate
For i = 1 To .UsedRange.Rows.Count
If .Cells(i, 1) = "Isolate AST Results" Then
.Cells(i + 2, 1).Activate
'' NUT OUT FROM HERE
'' -----------------
'' Error 424 on next line - Object Required
.Range(i + 2, 1).CurrentRegion
End If
Next
End With
' With xlWShExtract
' .Activate
' .ActiveSheet.Paste
' .Sheets(1).Select
' .Range(Selection + 2, Selection.End(xlDown)).Copy
' .Sheets("Extract").Activate
' .Sheets("Extract").Paste
' End With
'' -----------------
'' TO HERE
'add formulae to get the desired data
With xlWShExtract
' -------- for qualifier
' Must use RC[3] instead of "E2" for range source in formula (relative reference)
.Range("B2").FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""="",RC[3]))),LEFT(RC[3],2),IF(OR(LEFT(RC[3],1)="">"",LEFT(RC[3],1)=""<""),LEFT(RC[3],1),""=""))"
'now copy down the same number of rows as exists in column A
' (yet to do)
' -------- for value
' chagned B2 to RC[-1] and E2 to RC[2] (relative reference)
.Range("C2").FormulaR1C1 = "=IF(RC[-1]<>""="",RIGHT(RC[2],LEN(RC[2])-LEN(RC[-1])),RC[2])"
'now copy down the same number of rows as exists in column A
' (yet to do)
End With
GoTo Clean_up
End If
' ------ "MARKERS" Marker Rules Worksheet ------------------------------- '
' this worksheet will be used for importing into a temporary Access table
' copy and adpat from 'EXTRACT' once it's working
' have to try to 'skip' the blank rows... maybe a loop to find cells containing 'rule'?
' could be tricky... :-/
' ------ "RULES" Expert Triggered Rules Worksheet ----------------------- '
' this worksheet will be used for importing into a temporary Access table
' copy and adpat from 'MARKERS' once it's working
' ====== FIND PRELIMINARY DATA ================================================== '
' Notes: WORKING
Dim strSample As String
Dim strOrganism As String
Dim strTestName As String
' find the sample name and copy to string
With xlWSh
.Activate
For i = 1 To .UsedRange.Rows.Count
If .Cells(i, 1) = "Accession #:" Then
.Cells(i, 2).Activate
strSample = .Cells(i, 2).Value
End If
Next
End With
' find the organism name and copy to string
With xlWSh
For i = 1 To .UsedRange.Rows.Count
If .Cells(i, 1) = "Organism Name:" Then
.Cells(i, 2).Activate
strOrganism = .Cells(i, 2).Value
End If
Next
End With
' find the test name and copy to string
With xlWSh
For i = 1 To .UsedRange.Rows.Count
If .Cells(i, 1) = "Test Name:" Then
.Cells(i, 2).Activate
strTestName = .Cells(i, 2).Value
End If
Next
End With
'copy all three strings to temporary table
' (yet to do) = INSERT statement?
' ====== CLEAN UP ================================================== ============= '
' Notes: WORKING
Clean_up:
' delete sheet while testing (code works!)
ApXL.DisplayAlerts = False
xlWBk.Sheets("Extract").Delete
'xlWBk.Sheets("Markers").Delete
'xlWBk.Sheets("ExRules").Delete
ApXL.DisplayAlerts = True
' close instance of Excel
xlWBk.Save
xlWBk.Close
ApXL.Quit
Set xlWShExtract = Nothing
Set xlWSh = Nothing
Set xlWBk = Nothing
Set ApXL = Nothing
MsgBox "I've left everything neat and tidy for you"
End If
Exit_fImportPhoenix:
Exit Function
' ====== ERROR HANDLER ================================================== ======== '
Err_fImportPhoenix:
' delete sheet while testing (code works!)
ApXL.DisplayAlerts = False
xlWBk.Sheets("Extract").Delete
'xlWBk.Sheets("Markers").Delete
'xlWBk.Sheets("ExRules").Delete
ApXL.DisplayAlerts = True
' close instance of Excel
xlWBk.Save
xlWBk.Close
ApXL.Quit
Set xlWShExtract = Nothing
Set xlWSh = Nothing
Set xlWBk = Nothing
Set ApXL = Nothing
' "modFeatures" class module required for strings presented below
Msg = "Error # " & Str(Err.Number) & Chr(13) & " (" & Err.Description & ")"
Msg = Msg & Chr(13) & "in modImportPhoenix | fImportPhoenix"
MsgBox Msg, vbOKOnly, fstrDBname & ": Error", Err.HelpFile, Err.HelpContext
Resume Exit_fImportPhoenix
End Function
edit: forgot to say: triggered by a "Input from file" button on a form, and users (when i finish the code) don't have to do anything to any cell - all they have to do is point to the correct file (which, if you have standard file handling, you might be able to automate that bit too).
The code does all the 'cell finding' for you.
CHAOSinACT
10-20-2010, 06:48 PM
Thanks for the reply I'll dig through it :)
I know I'm vague... Its actually open as to what we'll need to do.
but any extra excel code is a blessing, thank you
wiklendt
10-20-2010, 07:51 PM
but any extra excel code is a blessing, thank you
tell me about it! finding access code is easy. finding excel code is easy. finding access code to manipulate excel is not so easy!
when i'm finished with my coding, i plan to put it up (maybe as a sample?) so that others might be able to use it (or bits of it, anyway).
CHAOSinACT
10-20-2010, 07:53 PM
yeah i found the same thing! code linking it to outlook has been even worse ;)