将DataGrid中的数据存入Excel ,我不会

[guojinghe]

?

[SoHo_Andy]

'将listView中的数据导出到Excel的例子
'希望对你有帮助

'这是我自己写的
Private Sub PrintToExcel()
On Error GoTo ErrTrap
Dim xlsApp As New Excel.Application

Dim xlsBook As New Excel.Workbook
Dim xlsSheet As New Excel.Worksheet
Dim i As Integer
Dim j As Integer
Dim xlsRow As Integer
Dim xlsCol As Integer

xlsCol = lsvShow.ColumnHeaders.Count - 3
xlsRow = 3

Set xlsBook = xlsApp.Workbooks.Add
Set xlsSheet = xlsBook.Worksheets(1)
xlsSheet.PageSetup.Orientation = xlLandscape '横向打印
frm_Wait.Show

xlsApp.Columns(1).NumberFormatLocal = "@"
'写入列名
For i = 1 To lsvShow.ColumnHeaders.Count - 3
xlsApp.Cells(xlsRow, i) = " " & Trim(lsvShow.ColumnHeaders(i).Text)
xlsApp.Columns(i).Select
xlsApp.Selection.ColumnWidth = lsvShow.ColumnHeaders(i).Width / 100
Next i
'xlsApp.Columns(1).AutoFit
xlsRow = xlsRow + 1
'写入列表内容
For i = 1 To lsvShow.ListItems.Count
xlsApp.Cells(xlsRow, 1) = Trim(lsvShow.ListItems(i).Text)
For j = 1 To lsvShow.ColumnHeaders.Count - 4
xlsApp.Cells(xlsRow, j + 1) = Trim(lsvShow.ListItems(i).SubItems(j))
xlsApp.Cells(xlsRow, j + 1).WrapText = True
Next j
xlsRow = xlsRow + 1
Next i

'写入标题和时间
xlsApp.Range(xlsApp.Cells(1, 1), xlsApp.Cells(1, xlsCol)).Select
With xlsApp.Selection
.MergeCells = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
xlsApp.Cells(1, 1) = labKeyName.Caption
xlsApp.Cells(1, 1).Font.Size = 24
xlsApp.Cells(1, 1).Font.Bold = True
xlsApp.Cells(2, 1) = "打印时间：" & Date

'设置边框
xlsApp.Range(xlsApp.Cells(3, 1), xlsApp.Cells(xlsRow, xlsCol)).Select
With xlsApp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With xlsApp.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlsApp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlsApp.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With xlsApp.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With xlsApp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
xlsApp.Visible = True
frm_Wait.Visible = False
Call VBA.AppActivate(xlsBook.name)

On Error GoTo 0
Exit Sub
ErrTrap:
On Error GoTo 0
End Sub


下面引用自小马哥

'*********************************************************
'* 名称：OutDataToExcel
'* 功能：将MsFlexGrid控件中显示的内容输出到Excel表格中进行打印
'*********************************************************
Public Sub OutDataToExcel(Flex As MSFlexGrid) '导出至Excel
Dim s As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
On Error GoTo Ert
Me.MousePointer = 11
Dim Excelapp As Excel.Application
Set Excelapp = New Excel.Application
On Error Resume Next
DoEvents
Excelapp.SheetsInNewWorkbook = 1
Excelapp.Workbooks.Add
Excelapp.ActiveSheet.Cells(1, 3) = s
Excelapp.Range("C1").Select
Excelapp.Selection.Font.FontStyle = "Bold"
Excelapp.Selection.Font.Size = 16
With Flex
k = .Rows
For i = 0 To k - 1
For j = 0 To .Cols - 1
DoEvents
Excelapp.ActiveSheet.Cells(3 + i, j + 1) = "'" & .TextMatrix(i, j)
Next j
Next i
End With
Me.MousePointer = 0
Excelapp.Visible = True
Excelapp.Sheets.PrintPreview
Ert:
If Not (Excelapp Is Nothing) Then
Excelapp.Quit
End If
End Sub

• 打赏
• 举报

回复 赞

[裸男]

http://www.csdn.net/develop/read_article.asp?id=14952

• 打赏
• 举报

回复 赞

[mingtian2008]

前提你的数据库 必须不要有什么限制？（不要有必须字段，不要有不允许为空）


Call ConRe 是连接 Microsoft Access 表 我想不用我多说了吧？在这里我就不写了

Public conexl As ADODB.Connection
Public reexl As ADODB.Recordset
Public appexl As Excel.Application
Public workexl As Excel.Workbook
Public workexlsh As Excel.Worksheet
Public rowexl As Excel.Range

Public Sub ConReExcel(PathOpen1 As String) 连接Excel
Set conexl = New ADODB.Connection
conexl.Open "provider=microsoft.jet.oledb.4.0;data source= " & PathOpen1 & " ;extended properties=excel 8.0;"
conexl.CursorLocation = adUseClient
Set reexl = New Recordset
End Sub

数据导出
Public Sub Excel_o(Table_Name As String, Data_Table As DataGrid, TitleString As String, PathSave As String)
Call ConRe
re.Open "select * from " & Table_Name & "", con, adOpenDynamic, adLockBatchOptimistic

If Data_Table.ApproxCount + 1 > 0 Then

Set appexl = New Excel.Application

Set workexl = appexl.Workbooks.Add

Set workexlsh = workexl.Worksheets.Add
workexlsh.Name = TitleString
Set rowexl = workexlsh.Rows(1)

For i = 1 To Data_Table.Columns.Count
Data_Table.Row = 0
rowexl.Cells(1, i) = re.Fields(i - 1).Name

Next

On Error Resume Next

For j = 0 To Data_Table.ApproxCount - 1

For i = 1 To Data_Table.Columns.Count
Data_Table.Col = i - 1
rowexl.Cells(j + 2, i) = Data_Table.Text


Next
Data_Table.Row = Data_Table.Row + 1
Next

workexlsh.SaveAs PathSave
appexl.Quit
End If
End Sub

数据导入
Public Sub Excel_I(Table_Name As String, Table_Name_exl As String, Data_Table As DataGrid, pathopen As String)
Call ConReExcel(pathopen)
reexl.Open "select * from [" & Table_Name_exl & "$] order by 还阅编号 ", conexl, adOpenDynamic, adLockBatchOptimistic

Set Data_Table.DataSource = reexl

Call ConRe

Data_Table.Row = 0
On Error Resume Next
For j = 0 To Data_Table.ApproxCount


Data_Table.Col = 0
sql1 = "insert into " & Table_Name & "( " & reexl.Fields(0).Name & ") values ('" & Data_Table.Text & "') "
Bianhao = Data_Table.Text
con.Execute sql1

For i = 1 To Data_Table.Columns.Count - 1
Data_Table.Col = i
Sql = "update " & Table_Name & " set " & reexl.Fields(i).Name & "='" & Data_Table.Text & "' where 还阅编号='" & Bianhao & "' "
con.Execute Sql
Next i

Data_Table.Row = Data_Table.Row + 1

Next j

MsgBox "数据成功导入！ ", vbInformation, "数据导入提示 "

Call TuShu_LiShiJiLu
Call TuShu_TongJi

End Sub

• 打赏
• 举报

回复 赞

[guojinghe]

我用的 “http://www.csdn.net/develop/read_article.asp?id=14952
Visual Basic 导出到 Excel 提速之法 lihonggen0（原作）”
但遇到新问题了！
用了上述代码，在开始的大概2、30次都很好，但突然有一次出现错误提示
Run-time error '1004’
命令不可用。因为使用该应用程序的许可已过期！
这是怎么回事呢？具体是运行下面一条语句出错：
Set xlBook = xlApp.Workbooks().Add
会不会是Excel的控件也有使用次数限制？

• 打赏
• 举报

回复 赞

[flc]

你看看是不是你用导出的数据是不是非常的大呀

• 打赏
• 举报

回复 赞

[guojinghe]

问题还没解决，把Office重装一次又好了。但不知什么时候会出问题

• 打赏
• 举报

回复 赞