如何避免使用 Access 从 Excel 中的公式导入错误
How to avoid importing errors from formulas in Excel with Access
我有一系列格式相同的电子表格，需要将其导入访问数据库。不幸的是，电子表格数据不是表格形式，所以我需要导入一堆特定的单元格。
我将特定的单元格读取到变量中并构造一个查询以将行插入 table。
当单元格包含等同于错误的公式时，代码失败。为避免错误，我必须插入 Null 而不是错误值。如何插入 Null 而不是错误值？
Public Function ImportSheet()
Dim xl As Object
Dim jobno, Address, PM As String
Dim EDate As Date
Dim SID As String, SM, SDepth, SCon As String
Dim SDate As Date
Dim Sby, SDesc, Tby, Inc, Crack, Crumb As String
Dim AD1, AD2, AD3, AL1, AL2, AL3 As Double
Dim SHCID As String
Dim SHCMass, ILength, IDiam, M0, M1, M2, M3, M4, M5, L0, L1, L2, L3, L4, L5, MC0, MC1, MC2, MC3, MC4, MC5 As Double
Dim ST0, ST1, ST2, ST3, ST4, ST5, SW0, SW10, SW30, SW1h, SW21h, SW24h, SWih, Esw As Double
Dim BSWCID As String
Dim BCMass, BIM, BFM As Double
Dim ASWCID As String
Dim ACMass, AIM, AFM, MCI, MCISw, MCFSw, SFS, WD, DD, ISS As Double
Set xl = CreateObject("Excel.Application")
Dim xfileName As Variant
xfileName = Dir("C:\Users\username\Desktop\Database\Sheets\*.xls")
DoCmd.SetWarnings (False)
On Error Resume Next
While xfileName <> ""
With xl.Workbooks.Open(fileName:="C:\Users\username\Desktop\Database\Sheets\" & xfileName)
With .Sheets("Working Sheet")
jobno = .Cells(3, "G").Value
Address = .Cells(3, "C").Value
PM = .Cells(2, "G").Value
EDate = .Cells(4, "C").Value
SID = .Cells(5, "C").Value
SM = .Cells(6, "C").Value
SDepth = .Cells(7, "C").Value
SCon = .Cells(8, "C").Value
SDate = .Cells(5, "G").Value
Sby = .Cells(6, "G").Value
SDesc = .Cells(10, "C").Value
Tby = .Cells(4, "G").Value
Inc = .Cells(7, "G").Value
Crack = .Cells(8, "G").Value
Crumb = .Cells(9, "G").Value
AD1 = .Cells(13, "C").Value
AD2 = .Cells(14, "C").Value
AD3 = .Cells(15, "C").Value
AL1 = .Cells(13, "D").Value
AL2 = .Cells(14, "D").Value
AL3 = .Cells(15, "D").Value
SHCID = .Cells(12, "G").Value
SHCMass = .Cells(13, "G").Value
ILength = .Cells(14, "G").Value
IDiam = .Cells(15, "G").Value
M0 = .Cells(19, "C").Value
M1 = .Cells(20, "C").Value
M2 = .Cells(21, "C").Value
M3 = .Cells(22, "C").Value
M4 = .Cells(23, "C").Value
M5 = .Cells(24, "C").Value
L0 = .Cells(19, "D").Value
L1 = .Cells(20, "D").Value
L2 = .Cells(21, "D").Value
L3 = .Cells(22, "D").Value
L4 = .Cells(23, "D").Value
L5 = .Cells(24, "D").Value
MC0 = .Cells(19, "E").Value
MC1 = .Cells(20, "E").Value
MC2 = .Cells(21, "E").Value
MC3 = .Cells(22, "E").Value
MC4 = .Cells(23, "E").Value
MC5 = .Cells(24, "E").Value
ST0 = .Cells(19, "F").Value
ST1 = .Cells(20, "F").Value
ST2 = .Cells(21, "F").Value
ST3 = .Cells(22, "F").Value
ST4 = .Cells(23, "F").Value
ST5 = .Cells(24, "F").Value
SW0 = .Cells(29, "B").Value
SW10 = .Cells(30, "B").Value
SW30 = .Cells(31, "B").Value
SW1h = .Cells(32, "B").Value
SW21h = .Cells(33, "B").Value
SW24h = .Cells(34, "B").Value
SWih = .Cells(28, "G").Value
Esw = .Cells(34, "G").Value
BSWCID = .Cells(43, "F").Value
BCMass = .Cells(44, "F").Value
BIM = .Cells(45, "F").Value
BFM = .Cells(46, "F").Value
ASWCID = .Cells(43, "G").Value
ACMass = .Cells(44, "G").Value
AIM = .Cells(45, "G").Value
AFM = .Cells(46, "G").Value
MCI = .Cells(50, "D").Value
MCISw = .Cells(51, "D").Value
MCFSw = .Cells(52, "D").Value
SFS = Abs(.Cells(52, "E").Value)
WD = .Cells(53, "G").Value
DD = .Cells(54, "G").Value
ISS = .Cells(56, "G").Value
xl.Workbooks(xfileName).Close SaveChanges:=False
End With
End With
On Error GoTo 0
xfileName = Dir
Wend
xfileName = ""
Set xl = Nothing
DoCmd.SetWarnings (True)
Dim SQL As String
SQL = "INSERT INTO Results ( JobNo, Address, PM, EDate, SID, SM, SDepth, SCon, SDate, SBy, SDesc, TBy, Inc, Crack, Crumb, " _
& "AD1, AD2, AD3, AL1, AL2, AL3, SHCID, SHCMass, ILength, IDiam, M0, M1, M2, M3, M4, M5, L0, " _
& "L1, L2, L3, L4, L5, MC0, MC1, MC2, MC3, MC4, MC5, ST0, ST1, ST2, ST3, ST4, ST5, SW0, SW10, SW30, SW1h, SW21h, " _
& "SW24h, SWih, Esw, BSWCID, BCMass, BIM, BFM, ASWCID, ACMass, AIM, AFM, MCI, MCISw, MCFSw, SFS, WD, DD, Iss ) " _
& "SELECT '" & jobno & "', '" & Address & "', '" & PM & "', #" & EDate & "#, '" & SID & "', '" & SM & "', '" & SDepth & "', '" & SCon & "', #" & SDate & "#, " _
& "'" & Sby & "', '" & SDesc & "', '" & Tby & "', '" & Inc & "', '" & Crack & "', '" & Crumb & "', '" & AD1 & "', " _
& "'" & AD2 & "', '" & AD3 & "', '" & AL1 & "', '" & AL2 & "', '" & AL3 & "', '" & SHCID & "', '" & SHCMass & "', " _
& "'" & ILength & "', '" & IDiam & "', '" & M0 & "', '" & M1 & "', '" & M2 & "', '" & M3 & "', '" & M4 & "', " _
& "'" & M5 & "', '" & L0 & "', '" & L1 & "', '" & L2 & "', '" & L3 & "', '" & L4 & "', '" & L5 & "', '" & MC0 & "', " _
& "'" & MC1 & "', '" & MC2 & "', '" & MC3 & "', '" & MC4 & "', '" & MC5 & "', '" & ST0 & "', '" & ST1 & "', '" & ST2 & "', '" & ST3 & "', " _
& "'" & ST4 & "', '" & ST5 & "', '" & SW0 & "', '" & SW10 & "', '" & SW30 & "', '" & SW1h & "', '" & SW21h & "', " _
& "'" & SW24h & "', '" & SWih & "', '" & Esw & "', '" & BSWCID & "', '" & BCMass & "', " _
& "'" & BIM & "', '" & BFM & "', '" & ASWCID & "', '" & ACMass & "', '" & AIM & "', '" & AFM & "', '" & MCI & "', " _
& "'" & MCISw & "', '" & MCFSw & "', '" & SFS & "', '" & WD & "', '" & DD & "', '" & ISS & "'"
DoCmd.RunSQL SQL
MsgBox "Done"
End Function
将变量声明为 Variant 以便能够将 Null 分配给它们。然后，在构造 select 语句时，不要引用这些值，而是在 构造它之前 引用它们：
Dim myvar as Variant
myvar = .Cells(x, y).Value
' We should make sure myvar don't contain apostrophes
myvar = IIf(TypeName(myvar) = "Error", "Null", "'" & myvar & "'")
更好的解决方案是使用 Access 的内置功能来创建新记录，以避免构造格式错误的查询字符串：
Dim myvar As Variant
Dim db As DAO.Database
Dim rs As DAO.Recordset
...
Set db = CurrentDb
Set rs = db.OpenRecordset("tablename")
With rs
.AddNew
![FieldName] = IIf(TypeName(myvar) = "Error", Null, myvar)
...
.Update
End With
以这种方式插入时，我们不需要引用我们的值等。
这里是如何修复源代码的精简版。它不仅展示了如何使用 .RunSQL，还展示了 .AddNew。
Option Explicit
Option Compare Database
Public Function ImportCell(myval As Variant)
If TypeName(myval) = "Error" Then
ImportCell = Null
Else
ImportCell = myval
End If
End Function
Public Function ToSqlString(myval As Variant) As Variant
Dim tmp As Variant
tmp = ImportCell(myval)
If IsNull(tmp) Then
ToSqlString = "Null"
Else
ToSqlString = "'" & myval & "'"
End If
End Function
Public Function ToSqlDate(myval As Variant) As Variant
Dim tmp As Variant
Dim dat As Variant
tmp = ImportCell(myval)
If IsNull(tmp) Then
ToSqlDate = "Null"
Exit Function
End If
On Error Resume Next
dat = CDate(myval)
dat = "#" & Format(dat, "yyyy-mm-dd") & "#"
If Err.Number <> 0 Then
ToSqlDate = "Null"
Err.Clear
Exit Function
End If
ToSqlDate = dat
End Function
Public Function ToSqlDouble(myval As Variant) As Variant
Dim tmp As Variant
Dim dbl As Double
tmp = ImportCell(myval)
If IsNull(tmp) Then
ToSqlDouble = "Null"
Exit Function
End If
On Error Resume Next
dbl = CDbl(myval)
If Err.Number <> 0 Then
ToSqlDouble = "Null"
Err.Clear
Exit Function
End If
ToSqlDouble = dbl
End Function
Public Sub ImportSheet()
Dim path As String
Dim filename As Variant
Dim app As Object
Dim wbk As Object
Dim sht As Object
Dim JobNo As Variant ' String
Dim SDate As Variant ' Date
Dim M1 As Variant ' Double
Dim query As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("Results")
Set app = CreateObject("Excel.Application")
path = "C:\Users\username\Desktop\Database\Sheets\"
filename = Dir(path & "*.xls")
DoCmd.SetWarnings False
app.Visible = True
While filename <> ""
' Get row data from the workbook
Set wbk = app.Workbooks.Open(filename:=path & filename)
Set sht = wbk.Sheets("Working Sheet")
' Debugging data: sht.Range(sht.cells(1, 1), sht.cells(100, 100)) = "=ROW() & ""x"" & COLUMN()"
If False Then
' Use DoCmd.RunSQL
JobNo = ToSqlString(sht.cells(3, 5)) ' string
SDate = ToSqlDate(sht.cells(5, 5)) ' date
M1 = ToSqlDouble(sht.cells(20, 3)) ' double
' Insert the row into the table
query = "INSERT INTO Results ( JobNo, SDate, M1 ) " & _
"SELECT " & JobNo & ", " & SDate & ", " & M1 & " "
'Debug.Print query
DoCmd.RunSQL query
Else
' Use RecordSet.AddNew
With rs
.AddNew
' The excel cells must contain the expected type of data.
' The type can be checked, using a technique similar (but simpler) to the ones used by the ToSqlXXXX-methods
![JobNo] = ImportCell(sht.cells(3, 5))
![SDate] = ImportCell(sht.cells(5, 5))
![M1] = ImportCell(sht.cells(20, 3))
.Update
End With
End If
wbk.Close SaveChanges:=False
' Get the next filename
filename = Dir
Wend
DoCmd.SetWarnings True
MsgBox "Done"
End Sub
我建议您从 sheet 中读取一个范围，将您需要的所有单元格包含到一个数组中，而不是多次引用 sheet。参见：
我有一系列格式相同的电子表格，需要将其导入访问数据库。不幸的是，电子表格数据不是表格形式，所以我需要导入一堆特定的单元格。
我将特定的单元格读取到变量中并构造一个查询以将行插入 table。
当单元格包含等同于错误的公式时，代码失败。为避免错误，我必须插入 Null 而不是错误值。如何插入 Null 而不是错误值？
Public Function ImportSheet()
Dim xl As Object
Dim jobno, Address, PM As String
Dim EDate As Date
Dim SID As String, SM, SDepth, SCon As String
Dim SDate As Date
Dim Sby, SDesc, Tby, Inc, Crack, Crumb As String
Dim AD1, AD2, AD3, AL1, AL2, AL3 As Double
Dim SHCID As String
Dim SHCMass, ILength, IDiam, M0, M1, M2, M3, M4, M5, L0, L1, L2, L3, L4, L5, MC0, MC1, MC2, MC3, MC4, MC5 As Double
Dim ST0, ST1, ST2, ST3, ST4, ST5, SW0, SW10, SW30, SW1h, SW21h, SW24h, SWih, Esw As Double
Dim BSWCID As String
Dim BCMass, BIM, BFM As Double
Dim ASWCID As String
Dim ACMass, AIM, AFM, MCI, MCISw, MCFSw, SFS, WD, DD, ISS As Double
Set xl = CreateObject("Excel.Application")
Dim xfileName As Variant
xfileName = Dir("C:\Users\username\Desktop\Database\Sheets\*.xls")
DoCmd.SetWarnings (False)
On Error Resume Next
While xfileName <> ""
With xl.Workbooks.Open(fileName:="C:\Users\username\Desktop\Database\Sheets\" & xfileName)
With .Sheets("Working Sheet")
jobno = .Cells(3, "G").Value
Address = .Cells(3, "C").Value
PM = .Cells(2, "G").Value
EDate = .Cells(4, "C").Value
SID = .Cells(5, "C").Value
SM = .Cells(6, "C").Value
SDepth = .Cells(7, "C").Value
SCon = .Cells(8, "C").Value
SDate = .Cells(5, "G").Value
Sby = .Cells(6, "G").Value
SDesc = .Cells(10, "C").Value
Tby = .Cells(4, "G").Value
Inc = .Cells(7, "G").Value
Crack = .Cells(8, "G").Value
Crumb = .Cells(9, "G").Value
AD1 = .Cells(13, "C").Value
AD2 = .Cells(14, "C").Value
AD3 = .Cells(15, "C").Value
AL1 = .Cells(13, "D").Value
AL2 = .Cells(14, "D").Value
AL3 = .Cells(15, "D").Value
SHCID = .Cells(12, "G").Value
SHCMass = .Cells(13, "G").Value
ILength = .Cells(14, "G").Value
IDiam = .Cells(15, "G").Value
M0 = .Cells(19, "C").Value
M1 = .Cells(20, "C").Value
M2 = .Cells(21, "C").Value
M3 = .Cells(22, "C").Value
M4 = .Cells(23, "C").Value
M5 = .Cells(24, "C").Value
L0 = .Cells(19, "D").Value
L1 = .Cells(20, "D").Value
L2 = .Cells(21, "D").Value
L3 = .Cells(22, "D").Value
L4 = .Cells(23, "D").Value
L5 = .Cells(24, "D").Value
MC0 = .Cells(19, "E").Value
MC1 = .Cells(20, "E").Value
MC2 = .Cells(21, "E").Value
MC3 = .Cells(22, "E").Value
MC4 = .Cells(23, "E").Value
MC5 = .Cells(24, "E").Value
ST0 = .Cells(19, "F").Value
ST1 = .Cells(20, "F").Value
ST2 = .Cells(21, "F").Value
ST3 = .Cells(22, "F").Value
ST4 = .Cells(23, "F").Value
ST5 = .Cells(24, "F").Value
SW0 = .Cells(29, "B").Value
SW10 = .Cells(30, "B").Value
SW30 = .Cells(31, "B").Value
SW1h = .Cells(32, "B").Value
SW21h = .Cells(33, "B").Value
SW24h = .Cells(34, "B").Value
SWih = .Cells(28, "G").Value
Esw = .Cells(34, "G").Value
BSWCID = .Cells(43, "F").Value
BCMass = .Cells(44, "F").Value
BIM = .Cells(45, "F").Value
BFM = .Cells(46, "F").Value
ASWCID = .Cells(43, "G").Value
ACMass = .Cells(44, "G").Value
AIM = .Cells(45, "G").Value
AFM = .Cells(46, "G").Value
MCI = .Cells(50, "D").Value
MCISw = .Cells(51, "D").Value
MCFSw = .Cells(52, "D").Value
SFS = Abs(.Cells(52, "E").Value)
WD = .Cells(53, "G").Value
DD = .Cells(54, "G").Value
ISS = .Cells(56, "G").Value
xl.Workbooks(xfileName).Close SaveChanges:=False
End With
End With
On Error GoTo 0
xfileName = Dir
Wend
xfileName = ""
Set xl = Nothing
DoCmd.SetWarnings (True)
Dim SQL As String
SQL = "INSERT INTO Results ( JobNo, Address, PM, EDate, SID, SM, SDepth, SCon, SDate, SBy, SDesc, TBy, Inc, Crack, Crumb, " _
& "AD1, AD2, AD3, AL1, AL2, AL3, SHCID, SHCMass, ILength, IDiam, M0, M1, M2, M3, M4, M5, L0, " _
& "L1, L2, L3, L4, L5, MC0, MC1, MC2, MC3, MC4, MC5, ST0, ST1, ST2, ST3, ST4, ST5, SW0, SW10, SW30, SW1h, SW21h, " _
& "SW24h, SWih, Esw, BSWCID, BCMass, BIM, BFM, ASWCID, ACMass, AIM, AFM, MCI, MCISw, MCFSw, SFS, WD, DD, Iss ) " _
& "SELECT '" & jobno & "', '" & Address & "', '" & PM & "', #" & EDate & "#, '" & SID & "', '" & SM & "', '" & SDepth & "', '" & SCon & "', #" & SDate & "#, " _
& "'" & Sby & "', '" & SDesc & "', '" & Tby & "', '" & Inc & "', '" & Crack & "', '" & Crumb & "', '" & AD1 & "', " _
& "'" & AD2 & "', '" & AD3 & "', '" & AL1 & "', '" & AL2 & "', '" & AL3 & "', '" & SHCID & "', '" & SHCMass & "', " _
& "'" & ILength & "', '" & IDiam & "', '" & M0 & "', '" & M1 & "', '" & M2 & "', '" & M3 & "', '" & M4 & "', " _
& "'" & M5 & "', '" & L0 & "', '" & L1 & "', '" & L2 & "', '" & L3 & "', '" & L4 & "', '" & L5 & "', '" & MC0 & "', " _
& "'" & MC1 & "', '" & MC2 & "', '" & MC3 & "', '" & MC4 & "', '" & MC5 & "', '" & ST0 & "', '" & ST1 & "', '" & ST2 & "', '" & ST3 & "', " _
& "'" & ST4 & "', '" & ST5 & "', '" & SW0 & "', '" & SW10 & "', '" & SW30 & "', '" & SW1h & "', '" & SW21h & "', " _
& "'" & SW24h & "', '" & SWih & "', '" & Esw & "', '" & BSWCID & "', '" & BCMass & "', " _
& "'" & BIM & "', '" & BFM & "', '" & ASWCID & "', '" & ACMass & "', '" & AIM & "', '" & AFM & "', '" & MCI & "', " _
& "'" & MCISw & "', '" & MCFSw & "', '" & SFS & "', '" & WD & "', '" & DD & "', '" & ISS & "'"
DoCmd.RunSQL SQL
MsgBox "Done"
End Function
将变量声明为 Variant 以便能够将 Null 分配给它们。然后，在构造 select 语句时，不要引用这些值，而是在 构造它之前 引用它们：
Dim myvar as Variant
myvar = .Cells(x, y).Value
' We should make sure myvar don't contain apostrophes
myvar = IIf(TypeName(myvar) = "Error", "Null", "'" & myvar & "'")
更好的解决方案是使用 Access 的内置功能来创建新记录，以避免构造格式错误的查询字符串：
Dim myvar As Variant
Dim db As DAO.Database
Dim rs As DAO.Recordset
...
Set db = CurrentDb
Set rs = db.OpenRecordset("tablename")
With rs
.AddNew
![FieldName] = IIf(TypeName(myvar) = "Error", Null, myvar)
...
.Update
End With
以这种方式插入时，我们不需要引用我们的值等。
这里是如何修复源代码的精简版。它不仅展示了如何使用 .RunSQL，还展示了 .AddNew。
Option Explicit
Option Compare Database
Public Function ImportCell(myval As Variant)
If TypeName(myval) = "Error" Then
ImportCell = Null
Else
ImportCell = myval
End If
End Function
Public Function ToSqlString(myval As Variant) As Variant
Dim tmp As Variant
tmp = ImportCell(myval)
If IsNull(tmp) Then
ToSqlString = "Null"
Else
ToSqlString = "'" & myval & "'"
End If
End Function
Public Function ToSqlDate(myval As Variant) As Variant
Dim tmp As Variant
Dim dat As Variant
tmp = ImportCell(myval)
If IsNull(tmp) Then
ToSqlDate = "Null"
Exit Function
End If
On Error Resume Next
dat = CDate(myval)
dat = "#" & Format(dat, "yyyy-mm-dd") & "#"
If Err.Number <> 0 Then
ToSqlDate = "Null"
Err.Clear
Exit Function
End If
ToSqlDate = dat
End Function
Public Function ToSqlDouble(myval As Variant) As Variant
Dim tmp As Variant
Dim dbl As Double
tmp = ImportCell(myval)
If IsNull(tmp) Then
ToSqlDouble = "Null"
Exit Function
End If
On Error Resume Next
dbl = CDbl(myval)
If Err.Number <> 0 Then
ToSqlDouble = "Null"
Err.Clear
Exit Function
End If
ToSqlDouble = dbl
End Function
Public Sub ImportSheet()
Dim path As String
Dim filename As Variant
Dim app As Object
Dim wbk As Object
Dim sht As Object
Dim JobNo As Variant ' String
Dim SDate As Variant ' Date
Dim M1 As Variant ' Double
Dim query As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("Results")
Set app = CreateObject("Excel.Application")
path = "C:\Users\username\Desktop\Database\Sheets\"
filename = Dir(path & "*.xls")
DoCmd.SetWarnings False
app.Visible = True
While filename <> ""
' Get row data from the workbook
Set wbk = app.Workbooks.Open(filename:=path & filename)
Set sht = wbk.Sheets("Working Sheet")
' Debugging data: sht.Range(sht.cells(1, 1), sht.cells(100, 100)) = "=ROW() & ""x"" & COLUMN()"
If False Then
' Use DoCmd.RunSQL
JobNo = ToSqlString(sht.cells(3, 5)) ' string
SDate = ToSqlDate(sht.cells(5, 5)) ' date
M1 = ToSqlDouble(sht.cells(20, 3)) ' double
' Insert the row into the table
query = "INSERT INTO Results ( JobNo, SDate, M1 ) " & _
"SELECT " & JobNo & ", " & SDate & ", " & M1 & " "
'Debug.Print query
DoCmd.RunSQL query
Else
' Use RecordSet.AddNew
With rs
.AddNew
' The excel cells must contain the expected type of data.
' The type can be checked, using a technique similar (but simpler) to the ones used by the ToSqlXXXX-methods
![JobNo] = ImportCell(sht.cells(3, 5))
![SDate] = ImportCell(sht.cells(5, 5))
![M1] = ImportCell(sht.cells(20, 3))
.Update
End With
End If
wbk.Close SaveChanges:=False
' Get the next filename
filename = Dir
Wend
DoCmd.SetWarnings True
MsgBox "Done"
End Sub
我建议您从 sheet 中读取一个范围，将您需要的所有单元格包含到一个数组中，而不是多次引用 sheet。参见：