经调试，可能你再获取数据时对excel表格进行了修改，所以退出时会提示是否保存，但又没有显示提示，从外观上看就是excel未退出，command7_click代码修改如下应该没问题（红色部分为修改部分）：
Private Sub Command7_Click() '题库导入
On Error GoTo err1
Dim ZJStr() As String '章节列表
Dim ZJId() As String
Dim FileStr As String
CommonDialog1.FileName = ""
CommonDialog1.Filter = "Excel表格文件|*.xls"
CommonDialog1.Action = 1
FileStr = CommonDialog1.FileName
If FileStr = "" Then
Exit Sub
End If
Label1.Caption = "正在分析章节信息，请稍后！"
Dim Sql As String
Dim MsgTxt As String
Dim Rs_Zj As ADODB.Recordset
Dim Rs As ADODB.Recordset
Sql = "select * from zjinfo "
Set Rs_Zj = ExecuteSQL(Sql, MsgTxt)
If InStr(MsgTxt, "错误") Then
MsgBox MsgTxt
Exit Sub
End If
ReDim ZJStr(0)
ReDim ZJId(0)
If Rs_Zj.RecordCount > 0 Then '========================获取章节信息 如果有
For i = 1 To Rs_Zj.RecordCount
ReDim Preserve ZJStr(i)
ReDim Preserve ZJId(i)
ZJStr(i) = Rs_Zj.Fields("zjname") & ""
ZJId(i) = Rs_Zj.Fields("zjid") & ""
Rs_Zj.MoveNext
Next i
End If
Sql = "select * from tminfo"
Set Rs = ExecuteSQL(Sql, MsgTxt)
If InStr(MsgTxt, "错误") Then
MsgBox MsgTxt
Exit Sub
End If
Dim NewApp As Excel.Application
Dim NewSheet As Excel.Worksheet
Dim NewBook As Excel.Workbook
Set NewApp = New Excel.Application
Set NewBook = NewApp.Workbooks.Open(FileStr, , , , "")
'第一位为路径，第五位为密码
Set NewSheet = NewBook.Worksheets(1)
'NewApp.Visible = True
For i = 2 To NewSheet.Cells.Count
Label1.Caption = "正在读取第" & i & 项
DoEvents
If Trim(NewSheet.Cells(i, 1)) = "" Then
Exit For
End If
'先判断该章节是否已经添加
For j = 1 To UBound(ZJId)
If ZJStr(j) = Trim(NewSheet.Cells(i, 8)) Then
Exit For
End If
Next j
If j > UBound(ZJId) Then '没有找到
Rs_Zj.AddNew
Rs_Zj.Fields("zjname") = Trim(NewSheet.Cells(i, 8))
Rs_Zj.Update
ReDim Preserve ZJStr(j)
ReDim Preserve ZJId(j)
ZJStr(j) = Trim(NewSheet.Cells(i, 8))
ZJId(j) = Rs_Zj.Fields("zjid") & ""
End If
Rs.AddNew
RichTextBox2.TextRTF = Trim(NewSheet.Cells(i, 1))
Rs.Fields("TMStra") = (RichTextBox2.TextRTF)
Dim a As String
If Len(NewSheet.Cells(i, 2)) > 2 Then
a = Left(NewSheet.Cells(i, 2), 2)
If InStr(a, "A") Then
NewSheet.Cells(i, 2) = Mid(NewSheet.Cells(i, 2), 2, Len(NewSheet.Cells(i, 2)))
End If
End If
If Len(NewSheet.Cells(i, 3)) > 2 Then
a = Left(NewSheet.Cells(i, 3), 2)
If InStr(a, "B") Then
NewSheet.Cells(i, 3) = Mid(NewSheet.Cells(i, 3), 2, Len(NewSheet.Cells(i, 3)))
End If
End If
If Len(NewSheet.Cells(i, 4)) > 2 Then
a = Left(NewSheet.Cells(i, 4), 2)
If InStr(a, "C") Then
NewSheet.Cells(i, 4) = Mid(NewSheet.Cells(i, 4), 2, Len(NewSheet.Cells(i, 4)))
End If
End If
If Len(NewSheet.Cells(i, 5)) > 2 Then
a = Left(NewSheet.Cells(i, 5), 2)
If InStr(a, "D") Then
NewSheet.Cells(i, 5) = Mid(NewSheet.Cells(i, 5), 2, Len(NewSheet.Cells(i, 5)))
End If
End If
If Len(NewSheet.Cells(i, 6)) > 2 Then
a = Left(NewSheet.Cells(i, 6), 2)
If InStr(a, "E") Then
NewSheet.Cells(i, 6) = Mid(NewSheet.Cells(i, 6), 2, Len(NewSheet.Cells(i, 6)))
End If
End If
Rs.Fields("XXA") = (Trim(NewSheet.Cells(i, 2)))
Rs.Fields("XXB") = (Trim(NewSheet.Cells(i, 3)))
Rs.Fields("XXC") = (Trim(NewSheet.Cells(i, 4)))
Rs.Fields("XXD") = (Trim(NewSheet.Cells(i, 5)))
Rs.Fields("XXE") = (Trim(NewSheet.Cells(i, 6)))
Rs.Fields("ZJID") = ZJId(j)
If Len(Trim(NewSheet.Cells(i, 7))) = "1" Then
If Trim(UCase(NewSheet.Cells(i, 7))) = "A" Or Trim(UCase(NewSheet.Cells(i, 7))) = "B" Or Trim(UCase(NewSheet.Cells(i, 7))) = "C" Or Trim(UCase(NewSheet.Cells(i, 7))) = "D" Or Trim(UCase(NewSheet.Cells(i, 7))) = "E" Then
Rs.Fields("TMtype") = "单选"
Select Case Trim(NewSheet.Cells(i, 7))
Case "A"
Rs.Fields("TMDA") = 0
Case "B"
Rs.Fields("TMDA") = 1
Case "C"
Rs.Fields("TMDA") = 2
Case "D"
Rs.Fields("TMDA") = 3
Case "E"
Rs.Fields("TMDA") = 4
End Select
End If
If Trim(NewSheet.Cells(i, 7)) = "0" Or Trim(NewSheet.Cells(i, 7)) = "1" Then
Rs.Fields("TMtype") = "判断"
Rs.Fields("TMDA") = Trim(NewSheet.Cells(i, 7))
End If
Else
Rs.Fields("TMtype") = "多选"
Dim DXStr As String
DXStr = ""
If InStr(Trim(NewSheet.Cells(i, 7)), "A") Then
DXStr = DXStr & "0"
Else
DXStr = DXStr & "6"
End If
If InStr(Trim(NewSheet.Cells(i, 7)), "B") Then
DXStr = DXStr & "1"
Else
DXStr = DXStr & "6"
End If
If InStr(Trim(NewSheet.Cells(i, 7)), "C") Then
DXStr = DXStr & "2"
Else
DXStr = DXStr & "6"
End If
If InStr(Trim(NewSheet.Cells(i, 7)), "D") Then
DXStr = DXStr & "3"
Else
DXStr = DXStr & "6"
End If
If InStr(Trim(NewSheet.Cells(i, 7)), "E") Then
DXStr = DXStr & "4"
Else
DXStr = DXStr & "6"
End If
Rs.Fields("TMDA") = (DXStr)
End If
Rs.MoveNext
Next i
Label1.Caption = "读取完毕！共读取" & i - 2 & "个记录"
Rs.MoveFirst
Label1.Caption = "正在重新分配题目号码！"
For i = 1 To UBound(ZJId)
DoEvents
Sql = "select * from tminfo where zjid=" & ZJId(i)
Set Rs = ExecuteSQL(Sql, MsgTxt)
Label1.Caption = "正在重新分配题目号码 ID：" & ZJId(i)
If Rs.RecordCount > 0 Then
For j = 1 To Rs.RecordCount
DoEvents
Rs.Fields("TMNum") = j
Rs.Update
Label1.Caption = "正在重新分配题目号码 ID：" & ZJId(i) & " 题目号码：" & j
Rs.MoveNext
Next j
End If
Next i
MsgBox "题目导入完毕！", vbInformation, "消息提示"
RichTextBox1.Text = ""
ListView2.HideSelection = False
ListView1.HideSelection = False
If ListView2.ListItems.Count > 0 Then
Call ListView2_ItemClick(ListView2.ListItems.Item(1))
End If
NewBook.Save
NewBook.Close
NewApp.Quit
Set NewApp = Nothing
err1:
If Err.Number > 0 Then
MsgBox Err.Description, vbCritical, "错误提示"
Exit Sub
End If
End Sub
文件导入器【电子表格导入到ACCESS】.rar
(753.54 KB)
2017-03-30 21:24
