修復VBA代碼中的數據類型轉換錯誤

Question

您好，我是VBA的新手，我已獲​​得此數據庫，我們必須在該數據庫中復制此網站上 excel文件中顯示的格式的值，並使用下面顯示的代碼將這些值排列在各個列和行中（因為格式是處都是excel值），然后使用按鈕將其插入到訪問表中。 這就是訪問表的樣子

現在，每當我嘗試使用該按鈕時，都會給我一個與Rst！Date = FinalArray（i，3）有關的錯誤，該錯誤是顯示在date列中的數據（基本上是日期）。

如果刪除該行（或暫時轉為注釋），則可以正確運行代碼，但是當然缺少與日期相對應的數據。 看到圖片，我知道如何獲取日期值有一個錯誤，但是我只能指出錯誤的位置或錯誤。 我得到的錯誤是： “運行時錯誤'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

Answer 1

只需將其從字符串轉換為日期，VBA和VB通常會進行轉換，但是在某些情況下（例如，使用Recordset），您必須顯式轉換，例如：

Rst!Date = CDate(FinalArray(i, 3))

確保日期與數據庫設置區域的格式相同，即dd / mm / yyyy或mm / dd / yyyy。