VB中Excel 2010的导入导出操作
编写人：左丘文
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
3、 导出到excel代码：
1 Private Sub cmdExport_Click()
2 ' Modify By KevinZhang 2014-8-22
3 ' 定义变量
4 Dim i, j, k, o, z As Long
5
6 Dim rs As ADODB.Recordset
7 Dim sFile As String
8 ' 初始化文件打开窗口
9 If txtFILE.Text <> "" Then
10 sFile = RTrim(txtFILE.Text)
11 Else ' 如果等于空,则关闭方法
12 MsgBox " 请选择要导出的文件名 ", vbCritical
13 Exit Sub
14 End If
15
16 If FileExists(sFile) Then
17 If MsgBox( " 存在相同的档案名称,要替代吗? ", vbQuestion + vbYesNoCancel) <> vbYes Then Exit Sub
18 End If
19
20 Screen.MousePointer = vbHourglass
21
22 On Error GoTo Err_Proc
23
24 ' 初始化循环的变量数值
25 i = 2
26 j = 1
27 ' 初始化Excel组建
28 Set xlApp = CreateObject( " Excel.Application ")
29 Set xlBook = xlApp.Workbooks.Add
30 Set xlsheet = xlBook.WorkSheets( " Sheet1 ")
31
32 ' 打开选定的文件
33 ' Set xlBook = xlApp.Workbooks.Open(sFile)
34 ' 设置其可见
35 ' xlApp.Visible = True
36 ' 设置其工作表的名称
37 Set xlsheet = xlBook.WorkSheets( " Sheet1 ") ' 设置活动工作表
38 ' 执行SQL连接方法,查询语句,和返回的文本
39 Set rs = ExecSQL( " select * from PACKMATDTL where YEAR= ' " & txtYEAR.Text & " ' AND IQUARTER=' " & txtIQUARTER.Text & " ' ", ConGamma)
40 ' 循环,到数据库的总行
41
42
43 xlsheet.Cells( 1, 1) = " 年份 " ' 给单元格（row,col）赋值
44 xlsheet.Cells( 1, 2) = " 季度 " ' 给单元格（row,col）赋值
45 xlsheet.Cells( 1, 3) = " 料号 " ' 给单元格（row,col）赋值
46 xlsheet.Cells( 1, 4) = " 单价 " ' 给单元格（row,col）赋值
47
48 For z = 1 To rs.RecordCount
49 ' 初始化列
50 o = 0
51 For k = 1 To rs.Fields.count
52 ' 给Excel列赋值
53 xlsheet.Cells(i, k) = rs.Fields(o).Value ' 给单元格（row,col）赋值
54 ' 列往后进一位
55 o = o + 1
56
57 Next
58 ' 数据库标往后一步
59 rs.MoveNext
60 ' 行往后一步
61 i = i + 1
62 j = j + 1
63 Next
64 ' xlsheet.PrintOut '打印工作表
65 xlBook.SaveAs (sFile)
66 xlBook.Close (True) ' 关闭工作簿
67 xlApp.Quit ' 结束EXCEL对象
68 Set xlApp = Nothing ' 释放xlApp对象
69 MsgBox " 共有 " & rs.RecordCount & " 条记录被导出 ", vbInformation
70 rs.Close
71 Set rs = Nothing
72 Screen.MousePointer = vbDefault
73 Exit Sub
74
75
76
77 Err_Proc:
78 Screen.MousePointer = vbDefault
79 MsgBox " 请确认您的电脑已安装Excel！ ", vbExclamation, " 提示 "
80
81
82
83 End Sub
2 ' Modify By KevinZhang 2014-8-22
3 ' 定义变量
4 Dim i, j, k, o, z As Long
5
6 Dim rs As ADODB.Recordset
7 Dim sFile As String
8 ' 初始化文件打开窗口
9 If txtFILE.Text <> "" Then
10 sFile = RTrim(txtFILE.Text)
11 Else ' 如果等于空,则关闭方法
12 MsgBox " 请选择要导出的文件名 ", vbCritical
13 Exit Sub
14 End If
15
16 If FileExists(sFile) Then
17 If MsgBox( " 存在相同的档案名称,要替代吗? ", vbQuestion + vbYesNoCancel) <> vbYes Then Exit Sub
18 End If
19
20 Screen.MousePointer = vbHourglass
21
22 On Error GoTo Err_Proc
23
24 ' 初始化循环的变量数值
25 i = 2
26 j = 1
27 ' 初始化Excel组建
28 Set xlApp = CreateObject( " Excel.Application ")
29 Set xlBook = xlApp.Workbooks.Add
30 Set xlsheet = xlBook.WorkSheets( " Sheet1 ")
31
32 ' 打开选定的文件
33 ' Set xlBook = xlApp.Workbooks.Open(sFile)
34 ' 设置其可见
35 ' xlApp.Visible = True
36 ' 设置其工作表的名称
37 Set xlsheet = xlBook.WorkSheets( " Sheet1 ") ' 设置活动工作表
38 ' 执行SQL连接方法,查询语句,和返回的文本
39 Set rs = ExecSQL( " select * from PACKMATDTL where YEAR= ' " & txtYEAR.Text & " ' AND IQUARTER=' " & txtIQUARTER.Text & " ' ", ConGamma)
40 ' 循环,到数据库的总行
41
42
43 xlsheet.Cells( 1, 1) = " 年份 " ' 给单元格（row,col）赋值
44 xlsheet.Cells( 1, 2) = " 季度 " ' 给单元格（row,col）赋值
45 xlsheet.Cells( 1, 3) = " 料号 " ' 给单元格（row,col）赋值
46 xlsheet.Cells( 1, 4) = " 单价 " ' 给单元格（row,col）赋值
47
48 For z = 1 To rs.RecordCount
49 ' 初始化列
50 o = 0
51 For k = 1 To rs.Fields.count
52 ' 给Excel列赋值
53 xlsheet.Cells(i, k) = rs.Fields(o).Value ' 给单元格（row,col）赋值
54 ' 列往后进一位
55 o = o + 1
56
57 Next
58 ' 数据库标往后一步
59 rs.MoveNext
60 ' 行往后一步
61 i = i + 1
62 j = j + 1
63 Next
64 ' xlsheet.PrintOut '打印工作表
65 xlBook.SaveAs (sFile)
66 xlBook.Close (True) ' 关闭工作簿
67 xlApp.Quit ' 结束EXCEL对象
68 Set xlApp = Nothing ' 释放xlApp对象
69 MsgBox " 共有 " & rs.RecordCount & " 条记录被导出 ", vbInformation
70 rs.Close
71 Set rs = Nothing
72 Screen.MousePointer = vbDefault
73 Exit Sub
74
75
76
77 Err_Proc:
78 Screen.MousePointer = vbDefault
79 MsgBox " 请确认您的电脑已安装Excel！ ", vbExclamation, " 提示 "
80
81
82
83 End Sub
有关更多的技术分享，大家可以加入我们的技术群，进行源码的分享。
欢迎加入技术分享群：238916811