split text to numbers with code

Help!!!

Still having a problem. I am trying to import data from an excell spreadsheet. The code below will show you how. However my problem is this. under sample label a2 for example, i need to retreive numbers and text or a combination of both into individual fields. (ei. table is called chemical the table will have fields such as "al-text", "al", "alkalinity", "alkalinity-text" and so on. the sample value which is listed in the a2 column are the values that will go in the coresponding fields. Access does not like combinations of format, therefore how can i get these values into my table.
How can i code something that places part of the value into different fields ie. ">" in field "al-text" which is has a text format and "0.05" in field "al" which has a number format. or if the value is text it will autimaticaly go to the "al-text" field

Hope someone can help? If there is a better way let me know.

PARAMETER UNITS MDL a2 a3


Al mg/L 0.03 0.06 >0.05
Alkalinity mg/L CaCO3 5 52 61
As mg/L 0.001 ND ND
B mg/L 0.01 0.15 <0.14
Ba mg/L 0.01 0.44 0.19
BOD 5 mg/L 1 2 3
Ca mg/L 1 22 39
Cd mg/L 0.01 ND ND
Cl mg/L 1 2 22
Co mg/L 0.01 ND ND
COD mg/L 3 13 10
Colour Pt/Co units 2 3 ND
Conductivity umhos/cm 3 127 <233
Cr mg/L 0.01 ND ND
Cu mg/L 0.01 ND ND
DOC mg/L 0.4 2.4 0.7
Fe mg/L 0.01 ND ND
Hardness mg/L CaCO3 1 67 122
K mg/L 1 ND 1
Mg mg/L 1 3 6
Mn mg/L 0.01 ND ND
N-NH3 mg/L 0.02 0.02 >0.05
N-NO2 mg/L 0.10 ND ND
N-NO3 mg/L 0.10 0.41 0.36
Na mg/L 1 2 3





Option Compare Database
Option Explicit
Dim DateCollected As Date
Dim DateSubmitted As Date
Dim LastColumn As Long
Dim LastRow As Long
Dim rstChemical As Recordset
Dim SampleCount As Long
Dim xl As Excel.Application

Private Sub Form_Load()
Me.Caption = PconProjectName & Me.Caption
lblProjectName.Caption = PconProjectName
End Sub

Private Sub cmdGetData_Click()
If OpenFiles Then
' RelocateSampleCells
FindLastRowAndColumn
FindDates
ProcessChemical
WrapUp
End If
End Sub

Private Function OpenFiles() As Boolean
On Error GoTo ErrOpenCancel
cdlCommon.ShowOpen
On Error GoTo 0
Set xl = CreateObject("Excel.Application")
xl.WindowState = xlMinimized
xl.Visible = True
xl.Workbooks.Open (cdlCommon.FileName)
Set rstChemical = CurrentDb.OpenRecordset("Chemical")
BeginTrans
OpenFiles = True
Exit Function
ErrOpenCancel:
' Nothing to to
End Function
Private Sub RelocateSampleCells()
If FindLabel("Parameter") = True Then
Range("D144:H185").Select
Selection.Cut
Range("I12").Select
ActiveSheet.Paste
Range("D188:H229").Select
Selection.Cut
Range("I56").Select
ActiveSheet.Paste
Range("D232:H273").Select
Selection.Cut
Range("I100").Select
ActiveSheet.Paste
Range("D276:H317").Select
Selection.Cut
Range("N12").Select
ActiveSheet.Paste
Range("D320:H361").Select
Selection.Cut
Range("N56").Select
ActiveSheet.Paste
Range("D364:H405").Select
Selection.Cut
Range("N100").Select
ActiveSheet.Paste
Range("A142:R506").Select
Selection.EntireRow.Delete
Range("C140").Select
ActiveCell.SpecialCells(xlLastCell).Select
ActiveWorkbook.Save
ActiveCell.SpecialCells(xlLastCell).Select
End Sub
Private Sub FindLastRowAndColumn()
LastRow = xl.ActiveCell.SpecialCells(xlLastCell).Row
LastColumn = xl.ActiveCell.SpecialCells(xlLastCell).Column
End Sub

Private Sub FindDates()
Dim CellAddress As Excel.Range
Dim CellValue As Variant
Dim X As Long
If FindLabel("Submitted") = True Then
For X = xl.ActiveCell.Column + 1 To LastColumn
CellValue = xl.Cells(xl.ActiveCell.Row, X).Value
If IsDate(CellValue) Then
DateSubmitted = CellValue
Exit For
End If
Next X
Else
DateSubmitted = 0
End If
If FindLabel("Collected") = True Then
For X = xl.ActiveCell.Column + 1 To LastColumn
CellValue = xl.Cells(xl.ActiveCell.Row, X).Value
If IsDate(CellValue) Then
DateCollected = CellValue
Exit For
End If
Next X
Else
DateCollected = 0
End If
End Sub

Private Function FindLabel(Label As String) As Boolean
Dim FindCell As Excel.Range
xl.Range("A1").Select
Set FindCell = xl.Cells.Find(What:=Label, After:=xl.ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If FindCell Is Nothing Then
FindLabel = False
MsgBox "Unable to find '" & Label & " ' label in sheet " & xl.ActiveSheet.Name
Else
FindLabel = True
FindCell.Select
End If
End Function

Private Sub ProcessChemical()
On Error GoTo ErrorExit
Dim CellValue As Variant
Dim ParameterColumn As Long
Dim ParameterRow As Long
Dim ParameterName As String
Dim c As Long, r As Long
If FindLabel("Parameter") = True Then
ParameterRow = xl.ActiveCell.Row
ParameterColumn = xl.ActiveCell.Column
For c = ParameterColumn + 1 To LastColumn
xl.Cells(ParameterRow, c).Activate
CellValue = xl.ActiveCell.Value
If Not IsEmpty(CellValue) Then
If CellValue <> "UNITS" And CellValue <> "MDL" Then ' Found sample
'If Left(CellValue, 1) = "S" Then ' Found sample
InitializeSample
For r = ParameterRow + 1 To LastRow
xl.Cells(r, c).Select
CellValue = xl.ActiveCell.Value
If IsEmpty(CellValue) Then
' do nothing
'If IsNumeric(CellValue) Then

Else

ParameterName = xl.Cells(r, ParameterColumn).Value
ParameterName = CheckParameterName(ParameterName)
If ParameterName > "" Then
If IsNumeric(CellValue) Then
rstChemical.Fields(ParameterName) = CellValue
Else
If IsObject(CellValue) Then
rstChemical.Fields(ParameterName) = "nd"
End If
End If
End If
End If
Next r
End If
End If
If rstChemical.EditMode = dbEditAdd Then rstChemical.Update
Next c
End If
Exit Sub
ErrorExit:
Dim e As Error
Dim msg As String
For Each e In Errors
msg = msg & e.Description & vbNewLine
Next e
Rollback
lblMessage.Caption = "Updates have been rolled back."
MsgBox msg
End
End Sub

Private Sub InitializeSample()
If rstChemical.EditMode = dbEditAdd Then
rstChemical.Update
End If
SampleCount = SampleCount + 1
rstChemical.AddNew
rstChemical![Sampler Name] = xl.ActiveCell.Value
rstChemical![Date Collected] = DateCollected
rstChemical![Date Submitted] = DateSubmitted
lblMessage.Caption = "Processing sample " & xl.ActiveCell.Value & " ..."
Me.Repaint
End Sub

Private Function CheckParameterName(ParameterName)
Dim f As Field
' Checks for words that are not proper parameter names and change then to the
' proper name. Blank out unwanted items (they will be discarded).
Select Case ParameterName
Case "Comment:"
ParameterName = ""
Case "Client:"
ParameterName = ""
Case "MDL = Method Detection Limit"
ParameterName = ""
Case "Parameter"
ParameterName = ""
Case "Tot.Susp.Solids"
ParameterName = "Total Solids"
Case "Tot.Solids"
ParameterName = "Total Solids"
Case "Al"
ParameterName = "Aluminum"
Case "Alkalinity As CACO3"
ParameterName = "Alkalinity"
Case "Ag"
ParameterName = "Silver"
Case "N-NH3"
ParameterName = "Ammonia"
Case "N-NH3 "
ParameterName = "Ammonia"
Case "N-NH3 (un-ionized)"
ParameterName = "Ammonia (un-ionized)"
Case "N-NO2"
ParameterName = "Nitrite"
Case "N-NO3"
ParameterName = "Nitrate"
Case "Na"
ParameterName = "Sodium"
Case "Ni"
ParameterName = "Nickel"
Case "Pb"
ParameterName = "Lead"
Case "Se"
ParameterName = "Selenium"
Case "Si"
ParameterName = "Silica"
Case "Aluminum-t"
ParameterName = "Aluminum-t"
Case "Zn"
ParameterName = "Zinc"
End Select
CheckParameterName = ParameterName
If ParameterName = "" Then Exit Function
' Check to make sure the parameter name matches a field name in the Chemical Table.
For Each f In rstChemical.Fields
If f.Name = ParameterName Then Exit Function
Next f
' This can only happen if the parameter name does not match any of the table field names.
MsgBox "Unexpected value: " & ParameterName & " encountered in the Parameter column. " & _
"Press ctl+Break to edit the program and add to the Select Case statement."
End Function

Private Sub WrapUp()
CommitTrans
rstChemical.Close
xl.ActiveWorkbook.Close
xl.Application.Quit
Set xl = Nothing
Name cdlCommon.FileTitle As "Imported - " & cdlCommon.FileTitle
lblProjectName.Caption = "Laboratory data succesfully transfered into the database."
lblMessage.Caption = SampleCount & " sample(s) have been added to the database."
End Sub

[seanm]

This isn't graceful, but could you put the data into a string variable and then check it with a

for x = 1 to len(tempStr)

if isnumeric(mid(tempStr,x,1)) then
numberStr=numberStr & mid(tempStr,x,1)
else
letterStr =letterStr & mid(tempStr,x,1)
end if

next x


numbericValue=Val(numberStr)

...and put the two variables into your table.

Where does this sit whithin my code? Not clear on what you are doing. i realize that you are using the len feature but how are you telling the text or number where to be placed in what field.

[seanm]

Mea Culpa. I misread your question and your code.
If someone else wanted to jump in here before I mispeak myself again, I'd be grateful...

But hey, I'm always willing to take another shot at it,
This is where your putting values into the recordset, correct?

If ParameterName > "" Then
If IsNumeric(CellValue) Then
rstChemical.Fields(ParameterName) = CellValue
Else
If IsObject(CellValue) Then
rstChemical.Fields(ParameterName) = "nd"
End If
End If
End If

And you want to put any cell value which is not numeric into a field which is basically "ParameterName" & "-text"?

Change your CheckParameterName Function and table to include the -text fields.
Change the above else statement to read:
ParameterName=ParameterName & "-text"
rstChemical.Fields(ParameterName) = CellValue

And if I'm still off in left field - someone please tell me.

Your close but this almost works i must have a variable set wrong. Take a look. If the Cellvalue is "<0.04" is this it therefore skips the code thas is if isnumeric.... and goes to if left cellvalue is > or cellvalue is < then rstchemicals.field (aluminum-t)= left(cellvalue,1). this should put the character > or < in the one field named aluminum-t for the text field and the i call the right function with the len function -1 to retreive the 0.04 and place that in the aluminum field which is a number field.

This gives me an error. When debugging i see the cellvallue but it does not separate the two when needed.

Help asap as usual!!!!!!

Code Below
Private Sub ProcessChemical()
On Error GoTo ErrorExit
Dim Cellvalue2 As Variant
Dim CellValue As Variant
Dim ParameterColumn As Long
Dim ParameterRow As Long
Dim ParameterName As String
Dim c As Long, r As Long
If FindLabel("Parameter") = True Then
ParameterRow = xl.ActiveCell.Row
ParameterColumn = xl.ActiveCell.Column
For c = ParameterColumn + 1 To LastColumn
xl.Cells(ParameterRow, c).Activate
CellValue = xl.ActiveCell.Value
If Not IsEmpty(CellValue) Then
If CellValue <> "UNITS" And CellValue <> "MDL" Then ' Found sample
'If Left(CellValue, 1) = "S" Then ' Found sample
InitializeSample
For r = ParameterRow + 1 To LastRow
xl.Cells(r, c).Select
CellValue = xl.ActiveCell.Value
Cellvalue2 = CellValue
If IsEmpty(CellValue) Then
' do nothing
Else
ParameterName = xl.Cells(r, ParameterColumn).Value
ParameterName = CheckParameterName(ParameterName)
If ParameterName > "" Then
Select Case (ParameterName)
Case Is = "Aluminum"
If IsNumeric(CellValue) Then
rstChemical.Fields("Aluminum") = CellValue
Else
If Left((Cellvalue2), 1) = "<" Or Left((Cellvalue2), 1) = ">" Then
rstChemical.Fields("Aluminum-t") = Left((Cellvalue2), 1)
rstChemical.Fields("aluminum") = Right(Cellvalue2, -1)
Else
If Left((CellValue), 1) = "n" Then
rstChemical.Fields("Aluminum") = (Left(Cellvalue2, 2))
End If
End If
End If
Case Is = "Alkalinity"
If IsNumeric(CellValue) Then
rstChemical.Fields("Alkalinity") = CellValue
Else
If Left((Cellvalue2), 1) = "<" Or Left((Cellvalue2), 1) = ">" Then
rstChemical.Fields("Alkalinity-t") = Left((Cellvalue2), 1)
rstChemical.Fields("Alkalinity") = Right(Cellvalue2, -1)
Else
If Left((CellValue), 1) = "n" Then
rstChemical.Fields("Aluminum") = (Left(Cellvalue2, 2))
End If
End If
End If
End Select
End If
End If
Next r
End If
End If
If rstChemical.EditMode = dbEditAdd Then rstChemical.Update
Next c
End If
Exit Sub
ErrorExit:
Dim e As Error
Dim msg As String
For Each e In Errors
msg = msg & e.Description & vbNewLine
Next e
Rollback
lblMessage.Caption = "Updates have been rolled back."
MsgBox msg
End
End Sub

[seanm]

Okay this code, can be used to split the cell value:

for x = 1 to len(CellValue) 'loops through the cell value
'this chunk checks to see if the character is numeric
'if it is it adds it to cellvaluenum
if isnumeric(mid(CellValue,x,1)) then
CellValueNum=CellValueNum & mid(CellValue,x,1)
else
'otherwise it gets put in CellValueStr
CellValueStr =CellValueStr & mid(CellValue,x,1)
end if
next x
'This line converts CellValueNum from a string to an number
CellValue(ParameterName)=Val(CellValueNum)


so if you start with >2.00
you'll end up with
CellValueStr = >.
CellValueNum = 200
The decimal point you can fix by adding in an Or clause in the if statement.

Any help?