楼主 热度 0 VB excel 数据库
Karlson,2012-12-31 23:28:29
[P][B]方法一：[/B][/P][P]把Excel当作数据库来操作（这样速度快）
或用Excel对象来做，读取数据，然后循环导入[/P][P]读取数据然后一条条的导进去，循环操作因为数据量大很慢。
如何把excel像数据库那样读？难道写成结构体数组么？
当作数据库操作：[/P][P]'引用ado：工程--->引用--->Microsoft ActiveX Data Object 2.x（版本号）
Private Sub Form_Load()
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
cn.CursorLocation = adUseClient
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path & "\temp.xls;Extended Properties='Excel 8.0;HDR=Yes'"
rs.Open "select * from [Sheet1$]", cn, adOpenDynamic, adLockOptimistic
Set DataGrid1.DataSource = rs
End Sub[/P][P][/P][P][B]方法二：[/B][/P][P]EXCEL文件要设置固定格式，还要设置命名范围，然后才可以导入
大致思路如下：
'// 设置打开 EXCEL 文件的连接字符串
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=excel文件名;Extended Properties=Excel 8.0"
'// 以记录集的形式打开 Excel 文件，adoConn 为 ADODB.Connection 对象
adoConn.Open strConn
'// 将数据插入到指定的表中（以ODBC的方式打开SQL数据库）
strSQL = "INSERT INTO [odbc;Driver={SQL Server};Server=服务器IP;Database=数据库;UID=用户名;PWD=密码].SQL中的表名 SELECT EXCEL中的字段 FROM EXCEL工作表名"
'// 执行导入语句
adoConn.Execute strSQL, , adExecuteNoRecords[/P][P][B]方法三：[/B][/P][P]Dim Conn As ADODB.Connection
Set Conn = New ADODB.Connection
Conn.Open "连接到你的数据库XJGL.MDB的字符串"
Conn.Execute "select * into tmptable from [excel 8.0;database=" + 你的excel表名 + "].[sheet名$]"
Conn.Execute "insert into xsda(学籍号,准考证号,姓名,性别,出生年月,班级)select 学籍号,准考证号,姓名,性别,出生年月,班级 from tmptable"
Conn.Execute "drop tabel tmptable"
Set Conn = Nothing[/P][P][B]VB新建Excel文档[/B][/P][P]Public xlApp As Excel.Application
Public xlBook As Excel.Workbook
Public xlChar As New Excel.Chart
Public xlSheet As New Excel.Worksheet
Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add
xlSheet.Cells(1, 1) = "测试" '写入内容
xlBook.SaveAs ("FILENAME") '保存文件
xlApp.Quit
Set xlApp = Nothing
本方法采用add添加excel文件和datasheet，然后用save保存。如果用xlApp.Visible=False，则自动生成文件。但是如果文件已经存在，则会弹出是否覆盖的提示。因此，最好先在程序中检查文件是否已经存在，如果存在，则用普通方法打开。如果不存在，则用add添加，并保存。[/P][P][B]vb导出数据到Excel[/B][/P][P]Public Function ExporToExcel(strOpen As String) '入参为SQL查询语句
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim FILENAME As String
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = False 'Excel在后台运行
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
' .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
With xlSheet.PageSetup
' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" ' & Gsmc
' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10统计时间："
.CenterHeader = "&""楷体_GB2312,常规""库存明细&""宋体"
' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人：" & Ygxm
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期：" & Date
.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
End With
FILENAME = App.Path & "\" & Date & ".Xls"
xlBook.SaveAs (FILENAME) '保存文件
xlApp.Quit
Set xlApp = Nothing
' xlApp.Application.Visible = True
' Set xlApp = Nothing '"交还控制给Excel
' Set xlBook = Nothing
' Set xlSheet = Nothing[/P][P]End Function[/P]
第1楼 Karlson,2012-12-31 23:30:03
Sub NewSht()
Dim Cn As Object, Arr1, wbnm$, Myr&
Dim Arr, i&, d, j&
Set d = CreateObject("Scripting.Dictionary")
wbnm = ThisWorkbook.Path & "\数据源.xls"
Set Cn = CreateObject("Adodb.Connection")
Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & wbnm
Myr = Sheet1.[f65536].End(xlUp).Row
Arr1 = Sheet1.Range("a2:q" & Myr)
Arr = Cn.Execute("Select * From [Sheet1$]").getrows
For i = 0 To UBound(Arr, 2)
d(Arr(5, i)) = i
Next
For i = 1 To UBound(Arr1)
If d.exists(Arr1(i, 6)) Then
For j = 1 To 5
Arr1(i, j) = Arr(j - 1, d(Arr1(i, 6)))
Next
For j = 12 To 16
Arr1(i, j) = Arr(j - 2, d(Arr1(i, 6)))
Next
Arr1(i, 7) = Arr(7, d(Arr1(i, 6)))
Arr1(i, 8) = Arr(6, d(Arr1(i, 6)))
Arr1(i, 9) = Arr(15, d(Arr1(i, 6)))
Arr1(i, 10) = Arr(8, d(Arr1(i, 6)))
End If
Next
Sheet1.Range("a2:q" & Myr) = Arr1
Cn.Close: Set Cn = Nothing
End Sub
第2楼 Karlson,2013-01-08 12:09:23
0481096272
1
Page created in 0.1875 seconds width 5 queries.