编写人：左丘文
2015-4-11
近来这已是第二篇在讨论VB的相关问题，今天在这里，我想与大家一起分享一下在VB中如何从Excel中导入数据和导出数据到Excel（程序支持excel2010），在此做个小结，以供参考。有兴趣的同学，可以一同探讨与学习一下，否则就略过吧。
1、 程序导入导出操作介面：
2、 从excel导入数据代码：
1 Private Sub cmdinput_Click()
2
3 'Modify By KevinZhang 2014-8-21
4 Dim sFile As String
5 Dim btrans As Boolean
6 sFile = txtFILE.Text
7 If Not FileExists(sFile) Then
8 MsgBox "指定的导入文件不存在，请重新选择！", vbOKOnly + vbExclamation
9 Exit Sub
10 End If
11 '连接excel
12 Dim conn
13 Set conn = CreateObject("ADODB.Connection")
14 'connExcelStr = "Provider = Microsoft.Jet.OLEDB.4.0 ; Data Source =" & sFile & ";Extended Properties='Excel 8.0;HDR=YES'"
15 'connExcelStr = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source =" & sFile & ";Extended Properties='Excel 12.0 Xml;HDR=YES;'"
16 'connExcelStr = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source =" & sFile & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=1'"
17 connExcelStr = "Provider=Microsoft.ACE.OLEDB.12.0; Persist Security Info=False;Data Source=" & sFile & "; Extended Properties='Excel 8.0;HDR=Yes;IMEX=2'"
18 On Error GoTo checkgetexcel
19 conn.Open connExcelStr
20 Dim rs As ADODB.Recordset
21 Set rs = New ADODB.Recordset
22 With rs
23 .ActiveConnection = conn
24 .LockType = adLockReadOnly
25 .CursorLocation = adUseClient
26 .CursorType = adOpenKeyset
27 .Open "select * from [Sheet1$]"
28 End With
29
30
31 Dim rs2 As ADODB.Recordset
32 Set rs2 = New ADODB.Recordset
33 Dim i As Integer
34 If (rs.RecordCount >= 1) Then
35 i = rs.RecordCount
36
37 '*****************************************************************************
38 '同时生成一个错误清单
39
40 '定义变量
41 Dim j, k, o, z As Long
42
43 '初始化循环的变量数值
44 j = 2
45 '初始化Excel组建
46 Set xlApp = CreateObject("Excel.Application")
47 Set xlBook = xlApp.Workbooks.Add
48 Set xlsheet = xlBook.WorkSheets("Sheet1")
49
50 '打开选定的文件
51 'Set xlBook = xlApp.Workbooks.Open(sFile)
52 '设置其可见
53 'xlApp.Visible = True
54 '设置其工作表的名称
55 Set xlsheet = xlBook.WorkSheets("Sheet1") '设置活动工作表
56 '执行SQL连接方法,查询语句,和返回的文本
57
58 '循环,到数据库的总行
59 xlsheet.Cells(1, 1) = "料号" '给单元格（row,col）赋值
60 xlsheet.Cells(1, 2) = "单价" '给单元格（row,col）赋值
61 xlsheet.Cells(1, 3) = "错误信息" '给单元格（row,col）赋值
62
63 '***********************************************************************
64 Call ShowInforDlg("正在导入数据，请稍候...")
65 ConGamma.beginTrans
66 btrans = True
67 rs.MoveFirst
68 Do While Not rs.EOF
69 Set rs2 = ExecSQL("Insert_PackMat_Auto '" & txtYEAR.Text & " ','" & txtIQUARTER.Text & "' ,'" _
70 & rs!PRONUM & "','" & rs!price & "'", ConGamma)
71
72
73 If rs2.RecordCount = 1 Then
74
75 If rs2.Fields(0).Value = "存在相同物料成本记录" Then
76 'MsgBox "导入失败,请先删除该料号：" & rs!PRONUM & "再导入!!", vbCritical
77
78 '*************************************************************************************************
79 '初始化列
80 o = 0
81 For k = 1 To rs.Fields.count
82 '给Excel列赋值
83 xlsheet.Cells(j, k) = rs.Fields(o).Value '给单元格（row,col）赋值
84 '列往后进一位
85 o = o + 1
86
87 Next
88 xlsheet.Cells(j, rs.Fields.count + 1) = "存在相同物料成本记录" '给单元格（row,col）赋值
89 '行往后一步
90 j = j + 1
91 '*******************************************************************************************
92 i = i - 1
93 End If
94 Else
95 'MsgBox "导入失败,请先检查该料号：" & rs!PRONUM, , vbCritical
96 '*************************************************************************************************
97 '初始化列
98 o = 0
99 For k = 1 To rs.Fields.count
100 '给Excel列赋值
101 xlsheet.Cells(j, k) = rs.Fields(o).Value '给单元格（row,col）赋值
102 '列往后进一位
103 o = o + 1
104
105 Next
106 xlsheet.Cells(j, rs.Fields.count + 1) = "请先检查该料号" '给单元格（row,col）赋值
107 '行往后一步
108 j = j + 1
109 '*******************************************************************************************
110
111 i = i - 1
112
113
114 End If
115
116 rs.MoveNext
117 Loop
118 ConGamma.CommitTrans
119 rs.MoveFirst
120 btrans = False
121 Call UnloadInforDlg
122 If rs.RecordCount > 0 Then
123 MsgBox "共有" & i & "条记录被导入,错误信息请阅导入文件目录的Error.xls文件", vbInformation
124 End If
125 End If
126 '**********************************************
127 'xlsheet.PrintOut '打印工作表
128 Dim ssfile() As String
129 Dim ssfile2 As String
130 ssfile = Split(sFile, "\")
131 For i = 0 To UBound(ssfile) - 1
132 ssfile2 = ssfile2 & ssfile(i) & "\"
133 Next
134 ssfile2 = ssfile2 & "Error.xls"
135 xlBook.SaveAs (ssfile2)
136 xlBook.Close (True) '关闭工作簿
137 xlApp.Quit '结束EXCEL对象
138 Set xlApp = Nothing '释放xlApp对象
139 '******************************************************
140 rs.Close
141 Set rs = Nothing
142 If Trim(txtYEAR.Text) <> "" Then
143 Call frmMDI.ITMDIAdminX.ControlSearch
144 Exit Sub
145 End If
146
147 checkgetexcel:
148 MsgBox "请检查excel是否存在，excel中是否有Sheet1的工作表。(系统默认读取excel的Sheet1的工作表)", vbInformation
149 If ERR.Number <> 0 Then
150 MsgBox ERR.Description
151 End If
152
153 Exit Sub
154 End Sub
2
3 'Modify By KevinZhang 2014-8-21
4 Dim sFile As String
5 Dim btrans As Boolean
6 sFile = txtFILE.Text
7 If Not FileExists(sFile) Then
8 MsgBox "指定的导入文件不存在，请重新选择！", vbOKOnly + vbExclamation
9 Exit Sub
10 End If
11 '连接excel
12 Dim conn
13 Set conn = CreateObject("ADODB.Connection")
14 'connExcelStr = "Provider = Microsoft.Jet.OLEDB.4.0 ; Data Source =" & sFile & ";Extended Properties='Excel 8.0;HDR=YES'"
15 'connExcelStr = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source =" & sFile & ";Extended Properties='Excel 12.0 Xml;HDR=YES;'"
16 'connExcelStr = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source =" & sFile & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=1'"
17 connExcelStr = "Provider=Microsoft.ACE.OLEDB.12.0; Persist Security Info=False;Data Source=" & sFile & "; Extended Properties='Excel 8.0;HDR=Yes;IMEX=2'"
18 On Error GoTo checkgetexcel
19 conn.Open connExcelStr
20 Dim rs As ADODB.Recordset
21 Set rs = New ADODB.Recordset
22 With rs
23 .ActiveConnection = conn
24 .LockType = adLockReadOnly
25 .CursorLocation = adUseClient
26 .CursorType = adOpenKeyset
27 .Open "select * from [Sheet1$]"
28 End With
29
30
31 Dim rs2 As ADODB.Recordset
32 Set rs2 = New ADODB.Recordset
33 Dim i As Integer
34 If (rs.RecordCount >= 1) Then
35 i = rs.RecordCount
36
37 '*****************************************************************************
38 '同时生成一个错误清单
39
40 '定义变量
41 Dim j, k, o, z As Long
42
43 '初始化循环的变量数值
44 j = 2
45 '初始化Excel组建
46 Set xlApp = CreateObject("Excel.Application")
47 Set xlBook = xlApp.Workbooks.Add
48 Set xlsheet = xlBook.WorkSheets("Sheet1")
49
50 '打开选定的文件
51 'Set xlBook = xlApp.Workbooks.Open(sFile)
52 '设置其可见
53 'xlApp.Visible = True
54 '设置其工作表的名称
55 Set xlsheet = xlBook.WorkSheets("Sheet1") '设置活动工作表
56 '执行SQL连接方法,查询语句,和返回的文本
57
58 '循环,到数据库的总行
59 xlsheet.Cells(1, 1) = "料号" '给单元格（row,col）赋值
60 xlsheet.Cells(1, 2) = "单价" '给单元格（row,col）赋值
61 xlsheet.Cells(1, 3) = "错误信息" '给单元格（row,col）赋值
62
63 '***********************************************************************
64 Call ShowInforDlg("正在导入数据，请稍候...")
65 ConGamma.beginTrans
66 btrans = True
67 rs.MoveFirst
68 Do While Not rs.EOF
69 Set rs2 = ExecSQL("Insert_PackMat_Auto '" & txtYEAR.Text & " ','" & txtIQUARTER.Text & "' ,'" _
70 & rs!PRONUM & "','" & rs!price & "'", ConGamma)
71
72
73 If rs2.RecordCount = 1 Then
74
75 If rs2.Fields(0).Value = "存在相同物料成本记录" Then
76 'MsgBox "导入失败,请先删除该料号：" & rs!PRONUM & "再导入!!", vbCritical
77
78 '*************************************************************************************************
79 '初始化列
80 o = 0
81 For k = 1 To rs.Fields.count
82 '给Excel列赋值
83 xlsheet.Cells(j, k) = rs.Fields(o).Value '给单元格（row,col）赋值
84 '列往后进一位
85 o = o + 1
86
87 Next
88 xlsheet.Cells(j, rs.Fields.count + 1) = "存在相同物料成本记录" '给单元格（row,col）赋值
89 '行往后一步
90 j = j + 1
91 '*******************************************************************************************
92 i = i - 1
93 End If
94 Else
95 'MsgBox "导入失败,请先检查该料号：" & rs!PRONUM, , vbCritical
96 '*************************************************************************************************
97 '初始化列
98 o = 0
99 For k = 1 To rs.Fields.count
100 '给Excel列赋值
101 xlsheet.Cells(j, k) = rs.Fields(o).Value '给单元格（row,col）赋值
102 '列往后进一位
103 o = o + 1
104
105 Next
106 xlsheet.Cells(j, rs.Fields.count + 1) = "请先检查该料号" '给单元格（row,col）赋值
107 '行往后一步
108 j = j + 1
109 '*******************************************************************************************
110
111 i = i - 1
112
113
114 End If
115
116 rs.MoveNext
117 Loop
118 ConGamma.CommitTrans
119 rs.MoveFirst
120 btrans = False
121 Call UnloadInforDlg
122 If rs.RecordCount > 0 Then
123 MsgBox "共有" & i & "条记录被导入,错误信息请阅导入文件目录的Error.xls文件", vbInformation
124 End If
125 End If
126 '**********************************************
127 'xlsheet.PrintOut '打印工作表
128 Dim ssfile() As String
129 Dim ssfile2 As String
130 ssfile = Split(sFile, "\")
131 For i = 0 To UBound(ssfile) - 1
132 ssfile2 = ssfile2 & ssfile(i) & "\"
133 Next
134 ssfile2 = ssfile2 & "Error.xls"
135 xlBook.SaveAs (ssfile2)
136 xlBook.Close (True) '关闭工作簿
137 xlApp.Quit '结束EXCEL对象
138 Set xlApp = Nothing '释放xlApp对象
139 '******************************************************
140 rs.Close
141 Set rs = Nothing
142 If Trim(txtYEAR.Text) <> "" Then
143 Call frmMDI.ITMDIAdminX.ControlSearch
144 Exit Sub
145 End If
146
147 checkgetexcel:
148 MsgBox "请检查excel是否存在，excel中是否有Sheet1的工作表。(系统默认读取excel的Sheet1的工作表)", vbInformation
149 If ERR.Number <> 0 Then
150 MsgBox ERR.Description
151 End If
152
153 Exit Sub
154 End Sub