导入时出现下标越界提示

张华　发表于：2021-03-22 09:15:21 　

复制

点击下载此附件

请问各位大神，导入时为什么会出现下标越界，请指导，感谢！

Top

leoyoung 发表于：2021-03-22 11:09:37

就你这个附件样本的问题

1、数据表名称

With objBook.Sheets("数据源")

......

2、字段的位置

........

rst.Fields(1) = .Range("A" & intN)
rst.Fields(2) = .Range("b" & intN)

Top

张华发表于：2021-03-22 15:35:17

leoyoung 老师！这种导入数据时间较长，二万条数据就要半个小时，请问能在原代码上修改来提高导入时间吗！

Top

leoyoung 发表于：2021-03-23 07:28:18

试一试用查询吧，不知是否可缩短时间？

原With...End With 的代码注释或删除

SQL = "insert into 数据源 select * from [数据源$] in '" & CurrentProject.Path & "\" & objBook.Name & "' 'Excel 8.0;'"

CurrentProject.Connection.Execute (SQL)

Top

张华发表于：2021-03-23 08:44:24

删除后提示找不到数据源对象

On Error GoTo err

Dim strPathName As String '输出文件路径名
Dim objApp As Object 'Excel程序
Dim objBook As Object 'Excel工作簿
Dim rst As Object '子窗体记录集
Dim curSum As Currency '折后金额总计
Dim intN As Integer '循环计数器
'通过对话框取得Excel文件名
With FileDialog(3) 'msoFileDialogOpen
.InitialFileName = CurrentProject.Path
.Filters.Clear
.Filters.Add "Microsoft Excel", "*.xlsx"
If .Show Then strPathName = .SelectedItems(1)
End With
'对话框取消则退出过程
If strPathName = "" Then Exit Sub

'设置鼠标指针为沙漏形状
' DoCmd.Hourglass True
'创建Excel对象
Set objApp = CreateObject("Excel.Application")
'打开模板文件
Set objBook = objApp.Workbooks.Open(strPathName)
'选中激活“销售订单”工作表
'objBook.Sheets("sheet1").Select '没有"sheet1"这个表名
'objApp.Visible = True
' With objApp.ActiveSheet '如果用ActiveSheet属性,就要事先设置属性objApp.Visible = True
SQL = "insert into 数据源 select * from [数据源] in '" & CurrentProject.Path & "\" & objBook.Name & "' 'Excel 8.0;'"
CurrentProject.Connection.Execute (SQL)
MsgBox "导入成功！", vbInformation, "提示"
objBook.Close
Set objBook = Nothing
Set objApp = Nothing
Set rst = Nothing
Exit Sub
err:
MsgBox err.Description
objBook.Close
Set objBook = Nothing
Set objApp = Nothing

Set rst = Nothing

Top

leoyoung 发表于：2021-03-23 09:26:31

唉！抄都抄错，少了$