wiklendt
i recommend chocolate
- Local time
- Tomorrow, 08:47
- Joined
- Mar 10, 2008
- Messages
- 1,746
oh, i hadn't noticed the unprintable character... that would certainly make a difference.
in any case, i have everything working (using late binding) up to the point of being ready to start bringing it all into access.
here's all the final code (also attached as a zipped .bas file) for anyone who might want to do similar things with excel from within access:
(edit: i should mention that this code 'cleans up' after itself, but allows you to view the xls before it does so with a message box "is everything ok", where you can look at the xls. i'll eventually remove this msgbox and cleanup, but while i'm still testing the whole process, so i've kept it in there for the meantime.)
Code:
Option Compare Database
Function fImportPhoenixs() As String
On Error GoTo Err_fImportPhoenix
' ====== DECLARATIONS =========================================================== '
'--General
Dim i As Long ' for start row
Dim j As Long ' for end row
Dim r As Long ' for row number
Dim C As Long ' for column number
Dim Msg As String
Dim fld As Field
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
'--Open Workbook
Dim strDialogTitle As String
Dim strPath As String
Dim strFileIsolate As String
'--Workbook Objects
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
'--Worksheet Objects
Dim xlWShIsolate As Object
Dim xlWShExtract As Object
Dim xlWShMarkers As Object
Dim xlWShExRules As Object
Dim Range As Object
Dim Rows As Object
Dim Columns As Object
Dim Selection As Object
' ====== OPEN WORKBOOK AND SHEET ================================================ '
' Notes: WORKING
strDialogTitle = "Select a file for import"
strPath = GetOpenFile_CLT(".\", strDialogTitle)
'If no file was selected then the PathStrg variable will be empty.
'If there was a file selected then.....
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 once code is finalised
' ====== ADD NEW WORKSHEETS ===================================================== '
' Notes: WORKING
' ---- set additional worksheets to variables (will be "Nothing" if don't exist)
On Error Resume Next
Set xlWShIsolate = xlWBk.Sheets("Isolate")
Set xlWShExtract = xlWBk.Sheets("Extract")
Set xlWShMarkers = xlWBk.Sheets("Markers")
Set xlWShExRules = xlWBk.Sheets("ExRules")
On Error GoTo Err_fImportPhoenix
' ---- now check which exist, and create those that don't
If Not xlWShIsolate Is Nothing Then
'sheet has already been generated (add a handler/msgbox here?)
Else
'does not exist, so add it
ApXL.Worksheets.Add.Move After:=ApXL.Worksheets(ApXL.Worksheets.Count)
ApXL.Sheets(ApXL.Worksheets.Count).Name = "Isolate"
Set xlWShIsolate = xlWBk.Sheets("Isolate")
End If
If Not xlWShExtract Is Nothing Then
'sheet has already been generated (add a handler/msgbox here?)
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")
End If
If Not xlWShMarkers Is Nothing Then
'sheet has already been generated (add a handler/msgbox here?)
Else
'does not exist, so add it
ApXL.Worksheets.Add.Move After:=ApXL.Worksheets(ApXL.Worksheets.Count)
ApXL.Sheets(ApXL.Worksheets.Count).Name = "Markers"
Set xlWShMarkers = xlWBk.Sheets("Markers")
End If
If Not xlWShExRules Is Nothing Then
'sheet has already been generated (add a handler/msgbox here?)
Else
'does not exist, so add it
ApXL.Worksheets.Add.Move After:=ApXL.Worksheets(ApXL.Worksheets.Count)
ApXL.Sheets(ApXL.Worksheets.Count).Name = "ExRules"
Set xlWShExRules = xlWBk.Sheets("ExRules")
End If
' ====== COPY DATA SETS ========================================================= '
' Notes: WORKING
With xlWSh 'work just with this worksheet for now
For i = 1 To .UsedRange.Rows.Count 'parse the used cells in column A
' ---- find antimicrobial data
'for alternative early binding code, see
http://www.access-programmers.co.uk/forums/showthread.php?t=200666
If .Cells(i, 1) = "Isolate AST Results" Then ' to find the string
' find the last data cell in the block
j = i + 2
Do Until .Cells(j, 1).Value = ""
j = j + 1
Loop
' copy the range to the new worksheet .Cells(RowNum, ColNum)
.Range(.Cells(i + 2, 1), .Cells(j - 1, 9)).Copy Destination:=xlWShExtract.Range("A2")
End If
' -- find Resistance Markers Rules
If .Cells(i, 1) = "Resistance Markers" Then
j = i + 1 'for the parsing worksheet
r = 2 'for the destination worksheet
Do Until .Cells(j, 1).Value = "Expert Triggered Rules"
'If the cell is _not_ blank, copy
If .Cells(j, 1).Value <> "" Then
' copy the range to the new worksheet
.Cells(j, 1).Copy Destination:=xlWShMarkers.Cells(r, 3)
.Cells(j, 3).Copy Destination:=xlWShMarkers.Cells(r, 2)
j = j + 1
r = r + 1
Else
'if the cell _is_ blank, test the next cell
j = j + 1
End If
Loop
End If
' -- find Expert Triggered Rules
If .Cells(i, 1) = "Expert Triggered Rules" Then
j = i + 1 'for the parsing worksheet
r = 2 'for the destination worksheet
Do Until .Cells(j, 1).Value = "Test Name:"
'If the cell is not blank, copy
If .Cells(j, 1).Value <> "" Then
' copy the range to the new worksheet
.Cells(j, 1).Copy Destination:=xlWShExRules.Cells(r, 3)
.Cells(j, 3).Copy Destination:=xlWShExRules.Cells(r, 2)
j = j + 1
r = r + 1
Else
'if the cell _is_ blank, test the next cell
j = j + 1
End If
Loop
End If
' -- find Isolate and Test details
' find the sample name and copy to string
If .Cells(i, 1) = "Accession #:" Then
.Cells(i, 2).Copy Destination:=xlWShIsolate.Range("A2")
End If
' find the organism name and copy to string
If .Cells(i, 1) = "Organism Name:" Then
.Cells(i, 2).Copy Destination:=xlWShIsolate.Range("B2")
End If
' find the test name and copy to string
If .Cells(i, 1) = "Test Name:" Then
.Cells(i, 2).Copy Destination:=xlWShIsolate.Range("C2")
End If
Next
End With
' ====== ARRANGE INITIAL DATA SET FOR IMPORT =================================== '
' Notes: WORKING
' ------ ANTIMICROBIAL RESULTS ------------------------------------------ '
' this worksheet will be used for importing into a temporary Access table
With xlWShExtract
' -------- move desired columns
.Columns("C:C").Cut Destination:=.Columns("E:E")
.Columns("I:I").Cut Destination:=.Columns("D:D")
.Columns("F:F").ClearContents
.Columns("G:G").ClearContents
.Columns("H:H").ClearContents
' -------- add appropariate headers
.Range("A1") = "Antimicrobial"
.Range("B1") = "Qualifier"
.Range("C1") = "Value"
.Range("D1") = "SIR"
.Range("E1") = "Reading"
' -------- add formulae down the rows
For i = 2 To .UsedRange.Rows.Count
.Cells(i, 2).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),""=""))"
.Cells(i, 3).FormulaR1C1 = "=IF(RC[-1]<>""="",RIGHT(RC[2],LEN(RC[2])-LEN(RC[-1])),RC[2])"
Next
End With
With xlWShIsolate
' -------- add appropariate headers
.Range("A1") = "Accession"
.Range("B1") = "Organism"
.Range("C1") = "Test"
.Range("D1") = "FileIsolate"
' -------- get file name (without the extension) from the file path
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=767
'Retrieved 2010-10-27
strFileIsolate = Mid$(strPath, InStrRev(strPath, "\") + 1)
strFileIsolate = Left$(strFileIsolate, InStrRev(strFileIsolate, ".") - 1)
' remove the automated prefix, if one exists
If Left(strFileIsolate, 10) = "Labreport " Then
strFileIsolate = Right(strFileIsolate, Len(strFileIsolate) - 10)
If Left(strFileIsolate, 9) = "Labreport" Then
strFileIsolate = Right(strFileIsolate, Len(strFileIsolate) - 9)
End If
End If
.Cells(2, 4).NumberFormat = "@" 'make sure the cell is formatted for text
.Cells(2, 4).Value = strFileIsolate 'paste the file isolate string here
End With
With xlWShMarkers
' -------- add appropariate headers
.Range("A1") = "RuleCode"
.Range("B1") = "RuleText"
.Range("C1") = "RawRules"
' -------- add formula down the rows
For i = 2 To .UsedRange.Rows.Count
.Cells(i, 1).FormulaR1C1 = "=RIGHT(RC[2],LEN(RC[2])-5)"
Next
End With
With xlWShExRules
' -------- add appropariate headers
.Range("A1") = "RuleCode"
.Range("B1") = "RuleText"
.Range("C1") = "RawRules"
' -------- add formula down the rows
For i = 2 To .UsedRange.Rows.Count
.Cells(i, 1).FormulaR1C1 = "=RIGHT(RC[2],LEN(RC[2])-5)"
Next
End With
' ====== IMPORT DATA =========================================================== '
' use spreasheet import thingy to get the four worksheets into access
' ====== CLEAN UP =============================================================== '
' Notes: WORKING
' Only need this while testing
Clean_up:
MsgBox "Everything OK?"
' delete extra sheets
ApXL.DisplayAlerts = False
xlWShIsolate.Delete
xlWShExtract.Delete
xlWShMarkers.Delete
xlWShExRules.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
xlWShIsolate.Delete
xlWShExtract.Delete
xlWShMarkers.Delete
xlWShExRules.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: ok, attached the file now!)
Last edited:
