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

View Code

 

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

View Code

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

 

欢迎加入技术分享群：238916811

 

转载于:https://www.cnblogs.com/bribe/p/4421311.html