VB中Excel 2010的导入导出操作

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

 

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

有关更多的技术分享，大家可以加入我们的技术群，进行源码的分享。

 

欢迎加入技术分享群：238916811