空间广告
在线情况
楼主
  • 头像
  • 级别
  • 门派
  • 职务总版主
  • 财富1
  • 积分634
  • 经验17284
  • 文章441
  • 注册2008-05-18
热度 0 VB excel 数据库
[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]
风之帝国校务管理系统
在线情况
2
  • 头像
  • 级别
  • 门派
  • 职务总版主
  • 财富1
  • 积分634
  • 经验17284
  • 文章441
  • 注册2008-05-18
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
 
风之帝国校务管理系统
在线情况
3
  • 头像
  • 级别
  • 门派
  • 职务总版主
  • 财富1
  • 积分634
  • 经验17284
  • 文章441
  • 注册2008-05-18
0481096272
风之帝国校务管理系统
loading...
loading...
loading...
loading...
loading...
loading...
loading...
回复帖子 注意: *为必填项
*验证信息 用户名 密码 注册新用户
*帖子名称
内容(最大50K)




其它选项 Alt+S快速提交
 


Powered by LeadBBS 9.1 licence.
Page created in 0.2656 seconds with 7 queries.