Question

我必须将Excel表格中的数据导入Access数据库。 Excel工作表和Access数据库的数据结构非常不同，因此必须进行大量的重新格式化/重组。所以我喜欢使用VBA导入数据。我知道我可以在VBA的Excel实例中打开工作表，然后在表格中读取，转换并保存。这是执行此操作的最佳方式，还是有一种方法可以将整个工作表加载到Access / VBA中，并在不打开Excel实例的情况下导航数据。感谢。

马塞尔

Answer 1

为什么不将Excel数据导入临时表（与Excel电子表格匹配），然后将其复制到正确的Access表中。

如果它是1-1记录副本（但使用重命名/转换），您可以使用查询来完成。否则，您可以在VBA中迭代输入的Excel表。

Answer 2

以下是最近将记录插入现有数据库的工作示例，这些字段都是从设计为输入表单的工作表中提取的。

Option Explicit

Private Sub insert_motor_to_DB()
'This sub will insert the motor data into the database as a new record

Dim msrSheet As Worksheet

Dim mtrSizeLoc As Range
Dim dateLoc As Range
Dim mtrSNLoc As Range
Dim mtrTechLoc As Range
Dim regLoc As Range
Dim custLoc As Range
Dim rigLoc As Range
Dim jobLoc As Range
Dim rotorSNLoc As Range
Dim rotorSizeLoc As Range
Dim rotorNULoc As Range
Dim rotorMeasLoc As Range
Dim rotorCoCLoc As Range
Dim statorSNLoc As Range
Dim statorSizeLoc As Range
Dim statorNULoc As Range
Dim statorMeasLoc As Range
Dim elastomerMFGLoc As Range
Dim BHAoFLoc As Range
Dim bendAngleLoc As Range
Dim protractorLoc As Range
Dim statorConfigLoc As Range
Dim topConLoc As Range
Dim topWBLoc As Range
Dim SoSLoc As Range
Dim stabSizeLoc As Range
Dim BAtypeLoc As Range
Dim botConLoc As Range
Dim fitLoc As Range
Dim comments As String
Dim regSTR As String
Dim custSTR As String
Dim rigSTR As String
Dim jobSTR As String
Dim stabSizeSTR As String
Dim rotorMeasSTR As String

Dim conn2 As Object ' connection
Dim rs As Object 'record set
Dim strConnection As String
Dim insertSQL As String

'Set up the range locations for validation
Set msrSheet = ThisWorkbook.Worksheets("Generate MSR")

Set mtrSizeLoc = msrSheet.Range("O5")
Set dateLoc = msrSheet.Range("O7")
Set mtrSNLoc = msrSheet.Range("O6")
Set mtrTechLoc = msrSheet.Range("O8")
Set regLoc = msrSheet.Range("O9")
Set custLoc = msrSheet.Range("O10")
Set rigLoc = msrSheet.Range("O11")
Set jobLoc = msrSheet.Range("O12")
Set rotorSNLoc = msrSheet.Range("O13")
Set rotorSizeLoc = msrSheet.Range("Q14")
Set rotorNULoc = msrSheet.Range("O14")
Set rotorMeasLoc = msrSheet.Range("O15")
Set rotorCoCLoc = msrSheet.Range("O16")
Set statorSNLoc = msrSheet.Range("O18")
Set statorSizeLoc = msrSheet.Range("Q19")
Set statorNULoc = msrSheet.Range("O19")
Set statorMeasLoc = msrSheet.Range("O20")
Set elastomerMFGLoc = msrSheet.Range("O21")
Set BHAoFLoc = msrSheet.Range("O23")
Set bendAngleLoc = msrSheet.Range("O24")
Set protractorLoc = msrSheet.Range("O25")
Set statorConfigLoc = msrSheet.Range("O28")
Set topConLoc = msrSheet.Range("O29")
Set topWBLoc = msrSheet.Range("O30")
Set SoSLoc = msrSheet.Range("O33")
Set stabSizeLoc = msrSheet.Range("O34")
Set BAtypeLoc = msrSheet.Range("O35")
Set botConLoc = msrSheet.Range("O36")
Set fitLoc = msrSheet.Range("J18")


'get comments
comments = msrSheet.OLEObjects("TextBox1").Object.Text


'Check for allowable zeroes = unfilled fields
If regLoc.value = 0 Then
    regSTR = "Not Assigned"
Else ' Do nothing at this time
    regSTR = regLoc.value
End If

If custLoc.value = 0 Then
    custSTR = "Not Assigned"
Else ' Do nothing at this time
    custSTR = custLoc.value
End If

If rigLoc.value = 0 Then
    rigSTR = "Not Assigned"
Else ' Do nothing at this time
    rigSTR = rigLoc.value
End If

If jobLoc.value = 0 Then
    jobSTR = "Not Assigned"
Else ' Do nothing at this time
    jobSTR = jobLoc.value
End If


If stabSizeLoc.value = 0 Then
    stabSizeSTR = "No Stab"
Else ' Do nothing at this time
    stabSizeSTR = stabSizeLoc.value
End If

'set up db connection
Set conn2 = CreateObject("ADODB.Connection")
'provide the path
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=C:\Users\Documents\xxMotorShopProject\DB_testingMTRS.accdb"

'open the DB
On Error GoTo ErrHandler2:
conn2.Open strConnection

'Perform the insert

insertSQL = "INSERT INTO tbl_mtrTEST ([mtrSize], [mtrSN], [buildDate],  [mtrTech],[region],[customer],[rig],[jobNum], " & _
            "[rotorSN],[rotorSize],[rotorNU], [rotorMeas], [rotorCoC], [statorSN], [statorSize], [statorNU], [statorMeas]," & _
            "[elastMFG], [AoF], [bendAngle], [protractorAngle], [statorConfig], [topCon], [topWB], [SoS]," & _
            "[stabSize], [BAtype], [botCon], [fit], [comments], [teardownYN]) " & _
        " VALUES (""" & mtrSizeLoc.value & """, """ & mtrSNLoc.value & """, """ & dateLoc.value & """, """ & mtrTechLoc.value & """," & _
        "  """ & regSTR & """, """ & custSTR & """, """ & rigSTR & """, """ & jobSTR & """," & _
        "  """ & rotorSNLoc.value & """, """ & rotorSizeLoc.value & """, """ & rotorNULoc.value & """, """ & Format(rotorMeasLoc.value, "0.000") & """," & _
        "  """ & rotorCoCLoc.value & """, """ & statorSNLoc.value & """, """ & statorSizeLoc.value & """, """ & statorNULoc.value & """," & _
        "  """ & Format(statorMeasLoc.value, "0.000") & """, """ & elastomerMFGLoc.value & """, """ & BHAoFLoc.value & """, """ & Format(bendAngleLoc.value, "0.00") & """," & _
        "  """ & Format(protractorLoc.value, "0.00") & """, """ & statorConfigLoc.value & """, """ & topConLoc.value & """, """ & topWBLoc.value & """," & _
        "  """ & SoSLoc.value & """, """ & stabSizeSTR & """, """ & BAtypeLoc.value & """, """ & botConLoc.value & """, """ & fitLoc & """ ," & _
        "  """ & comments & """,""" & "No Teardown""" & " ); "

On Error GoTo ErrHandler3:
conn2.Execute insertSQL


Application.Run "clear_MSR.clear_MSR"

JumpOut2:
JumpOut3:
conn2.Close
Set conn2 = Nothing

Exit Sub

ErrHandler2:
 MsgBox "The database file can not be accessed.  Please report this behavior.", , "Database Connection Error"
 Application.Run ("ERR_DB_Open.emailERR_openDB")
 Resume JumpOut2:

ErrHandler3:
 MsgBox "The database write failed.  Please report this behavior.", , "Database Write Error"
 Application.Run ("ERR_DB_Write.emailERR_writeDB")
 Resume JumpOut3:

End Sub

错误处理模块是outlook的电子邮件。这是另一个话题。清除工作表的模块只会清除位置。

如果您要编写VBA以将记录插入Access，这可能会帮助您解决问题。

顺便从工作簿中的其他代码调用私有模块，您必须这样做：

Application.Run "modulename.methodname", argument1, argument2 'if there are any arguments

这不是一个很长的过程，设置您的字段名称和构建查询的工作表位置会占用最多的空间/时间。

插入将添加记录并自动为行分配新ID。

干杯 - WWC

将Excel数据导入Access

2 个答案: