修复了VBA代码中的数据类型转换错误

时间：2018-07-19 18:25:31

标签： vba ms-access access-vba

您好，我是VBA的新手，我已获​​得此数据库，我们必须在该数据库中复制excel文件on this website中所示格式的值，并使用以下代码将这些值排列在各个列中，并行（因为excel值上的格式无处不在），然后使用按钮将其插入到访问表中。 this is what the access table looks like

现在，每当我尝试使用该按钮时，都会给我一个与Rst！Date = FinalArray（i，3）有关的错误，该错误是显示在date列中的数据（基本上是日期）。

如果我删除该行（或暂时转为注释），则可以正确运行代码，但是当然缺少与日期相对应的数据。 see picture 我知道在日期值的获取方法上存在错误，但我只能指出错误的位置或错误。 我得到的错误是：“运行时错误'3427：数据类型转换错误” 

  Private Sub cmdCopy_Click()
  DoCmd.SetWarnings False
  DoCmd.RunSQL "DELETE * FROM TblTempLabs"
   DoCmd.SetWarnings True
  Dim objData As New MSForms.DataObject
  Dim strText As String
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim m As Long
  Dim ComponentNumber As Integer
  Dim Component(100, 2) As Long
  Dim LineArray(8000) As String
  Dim labname As Integer

  'get text from Clipboard
  objData.GetFromClipboard
  strText = objData.GetText()
  ' replace double empty lines with single
   StrLength = Len(strText)
   strText = Replace(strText, Chr(13) & Chr(10) & Chr(13) & Chr(10), Chr(13) & Chr(10))
   ' parse text string into individual lines
   Start = 1
  Lines = 0
  Do While Start < Len(strText)
marker = InStr(Start, strText, Chr(10))
If Asc(Mid(strText, Start, 1)) <> 32 Then
    LineArray(Lines) = Mid(strText, Start, marker - Start)
    Start = marker + 1
    Lines = Lines + 1
       Else: Start = marker + 1
       End If
  Loop
    For j = 0 To Lines - 1
    For m = 1 To 12
    LineArray(j) = Replace(LineArray(j), "  " & m & "/", " &" & m & "/")
   Next m
   LineArray(j) = LineArray(j) & "& "
   Next j
   Endarray = j
    'objData.SetText strSummary
   'objData.PutInClipboard
  ' determine column blocks and rows
   rownumber = 1
   block = 0
   Start = 1
   Dim RowPosition(40, 10) As Integer
  Dim FinalArray(6000, 20) As Variant
  For i = 0 To Lines
If Mid(LineArray(i), 1, 9) = "Component" Then
    Do While InStr(Start, LineArray(i), "&") <> 0
        RowPosition(block, 0) = i
        RowPosition(block, rownumber) = InStr(Start, LineArray(i), "&") + 1
        rownumber = rownumber + 1
        Start = InStr(Start, LineArray(i), "&") + 1
    Loop
    block = block + 1
    Start = 1
    rownumber = 1

End If
          Next i
  Test = 0
  final = 0
  For i = 0 To 40
  If RowPosition(i, 0) > 0 Then Test = Test + 1
  Next i
  Test = Test + 1
  Dim Labend As Integer
 For block = 0 To Test
      If block + 1 = Test Then
    Labend = Lines
    Else: Labend = RowPosition(block + 1, 0) - 1
End If
For i = RowPosition(block, 0) To Labend
    If Mid(LineArray(i), 1, 9) = "Component" Then
        Labnameposition = InStr(1, LineArray(i), "Latest") - 1
    End If
    If Mid(LineArray(i), 1, 9) <> "Component" Then
        strLabName = Mid(LineArray(i), 1, Labnameposition)
        strLabName = Replace(strLabName, " ", "")
        strRefRange = Mid(LineArray(i), Labnameposition + 1, RowPosition(block, 1) - Labnameposition - 2)
        strRefRange = Replace(strRefRange, " ", "")
        For j = 1 To 6
            DateStart = RowPosition(block, j)
            DateLength = RowPosition(block, j + 1) - RowPosition(block, j) - 1
            If DateLength > 0 Then
                strDate = Mid(LineArray(RowPosition(block, 0)), DateStart, DateLength)
                strDate = Replace(strDate, " ", "")
                strResult = Mid(LineArray(i), DateStart, DateLength - 2)
                strResult = Replace(strResult, " ", "")
                strDate = Replace(strDate, Chr(13), "")
                If Len(strResult) > 0 And strResult <> "NP" Then
                    FinalArray(final, 0) = strLabName
                    FinalArray(final, 1) = strRefRange
                    FinalArray(final, 2) = strResult
                    FinalArray(final, 3) = strDate
                    final = final + 1
                End If
            End If
        Next j
    End If
Next i
  Next block


   totaltest = 0
   Do While FinalArray(totaltest, 0) <> ""
    totaltest = totaltest + 1
   Loop

   Dim db As DAO.Database
   Dim Rst As DAO.Recordset
   Set db = CurrentDb
  Set Rst = db.OpenRecordset("TblTempLabs")
   For i = 0 To totaltest - 1
If InStr(1, FinalArray(i, 2), "(L)") > 0 Then
    FinalArray(i, 6) = "Low"
    FinalArray(i, 5) = Replace(FinalArray(i, 2), "(L)", "")
End If
If InStr(1, FinalArray(i, 2), "(H)") > 0 Then
    FinalArray(i, 6) = "High"
    FinalArray(i, 5) = Replace(FinalArray(i, 2), "(H)", "")
End If
If InStr(1, FinalArray(i, 2), "(A)") > 0 Then
    FinalArray(i, 6) = "Abnormal"
    FinalArray(i, 5) = Replace(FinalArray(i, 2), "(A)", "")
End If
If IsNumeric(FinalArray(i, 2)) = True Then
FinalArray(i, 5) = FinalArray(i, 2)
FinalArray(i, 6) = "Normal"
End If
If InStr(1, FinalArray(i, 2), ":") > 0 Then
FinalArray(i, 5) = Right(FinalArray(i, 2), Len(FinalArray(i, 2)) - InStr(1, FinalArray(i, 2), ":"))
FinalArray(i, 5) = Replace(FinalArray(i, 5), ".", "")
End If
If InStr(1, FinalArray(i, 2), "Negative") > 0 Or _
    InStr(1, FinalArray(i, 2), "neg") > 0 Or _
    InStr(1, FinalArray(i, 2), "nonreactive") > 0 Or _
    InStr(1, FinalArray(i, 2), "non-reactive") > 0 Then
FinalArray(i, 6) = "Negative"
End If
If InStr(1, FinalArray(i, 2), "Positive") > 0 Then FinalArray(i, 6) = "Positive"
If InStr(1, FinalArray(i, 2), "normal") > 0 Then FinalArray(i, 6) = "Normal"
If InStr(1, FinalArray(i, 2), "trace") > 0 Then FinalArray(i, 6) = "Trace"
If InStr(1, FinalArray(i, 0), "crp") > 0 And InStr(1, FinalArray(i, 2), "<") > 0 Then
FinalArray(i, 6) = "Negative"
End If
If InStr(1, FinalArray(i, 0), "rheumatoid") > 0 And InStr(1, FinalArray(i, 2), "<") > 0 Then
FinalArray(i, 6) = "Negative"
End If
If InStr(1, FinalArray(i, 0), "antinuclear") > 0 And Val(FinalArray(i, 5)) > 160 Then
FinalArray(i, 6) = "Positive"
End If
If InStr(1, FinalArray(i, 2), "ANAtiter:greater") > 0 Then
FinalArray(i, 5) = 640
FinalArray(i, 6) = "Positive"
End If
If InStr(1, FinalArray(i, 2), "nocryo") > 0 Then FinalArray(i, 6) = "Negative"
If (InStr(1, FinalArray(i, 0), "estimatedglom") > 0 Or _
InStr(1, FinalArray(i, 0), "estGFR") > 0) And _
InStr(1, FinalArray(i, 2), ">") > 0 Then
FinalArray(i, 6) = "Normal"
End If
       Rst.AddNew
      Rst!Test = FinalArray(i, 0)
      Rst!refrange = FinalArray(i, 1)
      Rst!ResultComment = FinalArray(i, 2)
      Rst!Date = FinalArray(i, 3)
      If (FinalArray(i, 5)) = Empty Or Not IsNumeric(FinalArray(i, 5)) Then
      Rst!ResultNumeric = Empty
      Else: Rst!ResultNumeric = CDec(FinalArray(i, 5))
      End If
      Rst!ResultBoolean = FinalArray(i, 6)
      Rst!ID = Me.Text55
      Rst.Update
  Next i
 Dim str As String
 Rst.MoveFirst
Do While Not Rst.EOF
          str = Rst!Test
              Select Case str

                  Case ""
                      Rst.Edit
                      Rst!Test = "ESR"
                      Rst.Update
                       str = ""
                  Case Else
                 str = ""
             End Select
         Rst.MoveNext
      Loop
 Rst.Close
 Set db = Nothing
 Me.Child40.Requery
 End Sub

1 个答案:

答案 0 :(得分：0)

只需将其从字符串转换为日期，VBA和VB通常会处理转换，但在某些情况下（例如使用Recordset），您必须显式转换，例如：

onClick={(arg)=>{ this.f1(arg) }}

f1(values){
this.f2(values);
}

确保日期与数据库设置的区域格式相同，即dd / mm / yyyy或mm / dd / yyyy。

相关问题
最新问题