小弟我素新手向达人请教数据导入Excel问题:
用什么方法将数据集里的数据导入到excel中
要求:1.带标题
2.excel里的功能不能丢失(比如输入公式,数据筛选)
本人试过以下方法 :
1. Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
然后用xlsheet.cells(x,y) 往里面写数据(循环) 由于数据量大(几Q条),此方法被排除
2.用过fpspread控件(类似datagrade控件)自己带的方法导出 导出后excel部分功能无法使用
3.用过.bas 直接导出视图 但是视图的控制面又不广缺乏可控性
4.用crystal report内置功能导(此方法未试因小第不喜欢这种方式)
除以上方法 各达人还有什么好的方法请不吝赐教,或有好的控件也行 小弟在这先谢过了 小弟给不起什么分数请达人勿怪
用什么方法将数据集里的数据导入到excel中
要求:1.带标题
2.excel里的功能不能丢失(比如输入公式,数据筛选)
本人试过以下方法 :
1. Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
然后用xlsheet.cells(x,y) 往里面写数据(循环) 由于数据量大(几Q条),此方法被排除
2.用过fpspread控件(类似datagrade控件)自己带的方法导出 导出后excel部分功能无法使用
3.用过.bas 直接导出视图 但是视图的控制面又不广缺乏可控性
4.用crystal report内置功能导(此方法未试因小第不喜欢这种方式)
除以上方法 各达人还有什么好的方法请不吝赐教,或有好的控件也行 小弟在这先谢过了 小弟给不起什么分数请达人勿怪
*******************************************************************
'PURPOSE: 将DataGrid中的数据导出到EXCEL
'SUPPOSE:
'EFFECT:
'INPUTS: dgd:DataGrid
'RETURNS: String(a Empty String Or a Message String About of an error)
'*******************************************************************
Public Function ExportToExcel(ByRef dgd As DataGrid) As String
On Error GoTo ErrTrap
ExportToExcel = ""
Dim rs As New ADODB.Recordset
If Trim(TypeName(dgd.DataSource)) = "Recordset" Then
Set rs = dgd.DataSource
Else
Set rs = Nothing
ExportToExcel = "没有数据可导出"
Exit Function
End If
If rs.State = adStateClosed Then
ExportToExcel = "没有数据可导出"
Exit Function
End If
If rs.RecordCount <= 0 Then
ExportToExcel = "没有数据可导出"
Exit Function
Else
rs.MoveFirst
End If
Dim m_lngI As Long
Dim m_lngJ As Long
Dim m_Excel As Object
Dim m_Book As Object
Dim m_Sheet As Object
Set m_Excel = CreateObject("excel.application")
Set m_Book = m_Excel.Workbooks.Add
Set m_Sheet = m_Book.Worksheets(1)
m_Excel.Visible = True
For m_lngJ = 0 To dgd.Columns.Count - 1
'm_Sheet.Cells(1, m_lngJ + 1) = Rs.Fields(m_lngJ).Name
m_Sheet.Cells(1, m_lngJ + 1) = Trim(dgd.Columns(m_lngJ).Caption)
Next m_lngJ
'Rs.MoveFirst
For m_lngI = 0 To rs.RecordCount - 1
For m_lngJ = 0 To dgd.Columns.Count - 1
m_Sheet.Cells(m_lngI + 2, m_lngJ + 1) = Trim(rs.Fields(dgd.Columns(m_lngJ).DataField).Value)
Next m_lngJ
rs.MoveNext
Next m_lngI
m_Excel.Cells.EntireColumn.AutoFit
Set m_Sheet = Nothing
Set m_Book = Nothing
Set m_Excel = Nothing rs.MoveFirst
Set rs = Nothing Exit Function
ErrTrap:
ExportToExcel = "ExportToExcel:" & str(Err.Number) & "," & Err.Description
On Error GoTo 0
End Function
我想如果用的是ＳＱＬ是话使用存储过程应该速度会更好！
PS：可能方法名寫錯了。
Private Sub btnQuick_Click()
On Error GoTo errMessage
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim recArray As Variant Dim strDB As String
Dim fldCount As Integer
Dim recCount As Long
Dim iCol As Integer
Dim iRow As Integer
Screen.MousePointer = vbHourglass
Label1.Caption = "正在连接数据库..."
strDB = txtFile.Text
' 打开数据库连接
cnt.Open "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=" & txtFile.Text & ";"
' 查询数据库记录
Label1.Caption = "正在打开数据库，根据数据库的大小以及您电脑的配置，可能需要等待几分钟或更多时间。"
rst.Open "Select * from " & txtFile.Text, cnt
' 创建一个excel工作界面
Label1.Caption = "正在导出Excel文件..."
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets("sheet1")
' 显示Excel
xlApp.Visible = True
xlApp.UserControl = True
' Copy field names to the first row of the worksheet
fldCount = rst.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
Next ' Check version of Excel
If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
'EXCEL 2000 or 2002: Use CopyFromRecordset ' Copy the recordset to the worksheet, starting in cell A2
xlWs.Cells(2, 1).CopyFromRecordset rst
'Note: CopyFromRecordset will fail if the recordset
'contains an OLE object field or array data such
'as hierarchical recordsets
Dim ncount As Integer
ncount = 1
While Not rst.EOF
ncount = ncount + 1
Set xlWs = xlWb.Worksheets("sheet" & CStr(ncount))
fldCount = rst.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
Next
xlWs.Cells(2, 1).CopyFromRecordset rst
Wend
Set xlWs = xlWb.Worksheets("sheet3")
fldCount = rst.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
Next
xlWs.Cells(2, 1).CopyFromRecordset rst
Else
'EXCEL 97 or earlier: Use GetRows then copy array to Excel ' Copy recordset to an array
recArray = rst.GetRows
'Note: GetRows returns a 0-based array where the first
'dimension contains fields and the second dimension
'contains records. We will transpose this array so that
'the first dimension contains records, allowing the
'data to appears properly when copied to Excel ' Determine number of records recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array
' Check the array for contents that are not valid when
' copying the array to an Excel worksheet
For iCol = 0 To fldCount - 1
For iRow = 0 To recCount - 1
' Take care of Date fields
If IsDate(recArray(iCol, iRow)) Then
recArray(iCol, iRow) = Format(recArray(iCol, iRow))
' Take care of OLE object fields or array fields
ElseIf IsArray(recArray(iCol, iRow)) Then
recArray(iCol, iRow) = "Array Field"
End If
Next iRow 'next record
Next iCol 'next field ' Transpose and Copy the array to the worksheet,
' starting in cell A2
xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _
TransposeDim(recArray)
End If ' Auto-fit the column widths and row heights
xlApp.Selection.CurrentRegion.Columns.AutoFit
xlApp.Selection.CurrentRegion.Rows.AutoFit
Label1.Caption = ""
Screen.MousePointer = vbDefault
' Close ADO objects
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing ' Release Excel references
Set xlWs = Nothing
Set xlWb = Nothing Set xlApp = Nothing
errMessage:
If Err.Number <> 0 Then
Screen.MousePointer = vbDefault
Set rst = Nothing
Set cnt = Nothing
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
MsgBox Err.Description, , "错误提示"
Exit Sub
End If
End Sub