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