怎样把listview或msflexgrid中的数据导出到excel中？

[cbzdream]

怎样把listview或msflexgrid中的数据导出到excel中？

[hn123]

Public Sub OutDataToExcel(Flex As MSHFlexGrid) '导出至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

[羽毛之家]

Sub copyflexdatatoexcel(flex As MSFlexGrid)
On Error GoTo handle
Dim excelapp As Excel.Application
Dim excelworkbood As Excel.Workbook
Dim Rows, Cols As Integer
Dim iRow, hCol, iCol As Integer
Dim New_Col As Boolean

If flex.Rows <= 1 Then
MsgBox "没有数据！", vbInformation, App.Title
Exit Sub
End If

Set excelapp = CreateObject("Excel.application")
Set excelworkbood = excelapp.Workbooks.Add

Dim New_Column As Boolean
With flex
Rows = .Rows
Cols = .Cols
iRow = 0
iCol = 1
For hCol = 0 To Cols - 1
For iRow = 1 To Rows
excelapp.Cells(iRow, iCol).Value = .TextMatrix(iRow - 1, hCol)
Next iRow
iCol = iCol + 1
Next hCol
End With

excelapp.Rows(1).Font.Bold = True
excelapp.Cells.Select
excelapp.Columns.AutoFit
excelapp.Cells(1, 1).Select
excelapp.Application.Visible = True

Set excelworkbood = Nothing
Set excelapp = Nothing
flex.SetFocus
MsgBox "数据已经导出到Excel中。", vbInformation, "成功"
Exit Sub
handle:
MsgBox "数据导出失败！", vbCritical, "警告"

End Sub

[yijiansong]

循环取植－导出，ＯＫ

[EricaNet]

写在模块中，其他窗体就可以调用！

Public Function ListviewExport(ByVal ListView1 As ListView, ByVal CommonDialog1 As CommonDialog)
mvarVersion = vbLBV5
Dim SaveFilePath As String
Dim EXEString As String
Dim i As Integer, j As Integer
Dim InsertAmount As Integer
Dim WS As DAO.Workspace
Dim DB As DAO.Database
Dim TABL As DAO.TableDef
Dim RS As DAO.Recordset
'On Error GoTo err_handle
On Error Resume Next
With CommonDialog1
.CancelError = False
.Filter = "Excel文件(*.xls)|*.xls"
.DialogTitle = "将数据导出到Excel表(5.0)"
.ShowOpen
If Trim(.FileName) = "" Then
Exit Function
End If

SaveFilePath = .FileName
End With
'If ListView1.ColumnHeaders.Count <= 0 Then
' Exit Sub
'End If


Set WS = DBEngine.CreateWorkspace("WS", "Admin", "", dbUseJet)
Kill App.Path & "\report\listviewToExcel.mdb"
Set DB = WS.CreateDatabase(App.Path & "\report\listviewToExcel.mdb", dbLangGeneral, dbEncrypt)
Set TABL = DB.CreateTableDef("Excel")
For i = 1 To ListView1.ColumnHeaders.Count
TABL.Fields.Append TABL.CreateField(ListView1.ColumnHeaders.Item(i).Text, dbText, 250)
Next i
DB.TableDefs.Append TABL
Set RS = DB.OpenRecordset("Excel")
If ListView1.ListItems.Count > 0 Then
If ListView1.ColumnHeaders.Count >= (ListView1.ListItems.Item(1).ListSubItems.Count + 1) Then
InsertAmount = ListView1.ListItems.Item(1).ListSubItems.Count + 1
Else
InsertAmount = ListView1.ColumnHeaders.Count
End If
For i = 1 To ListView1.ListItems.Count
RS.AddNew
If ListView1.ListItems.Item(i).Text <> "" Then
RS.Fields(0) = ListView1.ListItems.Item(i).Text
Else: RS.Fields(0) = "//"
End If
For j = 1 To InsertAmount - 1
If ListView1.ListItems.Item(i).ListSubItems.Item(j).Text <> "" Then
RS.Fields(j) = ListView1.ListItems.Item(i).ListSubItems.Item(j).Text
Else
RS.Fields(j) = "//"
End If
Next j
RS.Update
Next i
End If
EXEString = "select * into [Excel " & Format(CStr(mvarVersion), "0.0") & ";database=" & SaveFilePath & "].LBExcel from Excel"
DB.Execute EXEString
RS.Close
DB.Close
WS.Close
Kill App.Path & "\report\listviewToExcel.mdb"
MsgBox "导出数据到Excel表成功!", vbInformation, "提示"
Exit Function
err_handle:
Select Case Err
Case 53:
Resume Next
End Select

End Function

[EricaNet]

'MSHFlexGrid控件的导出
Public Function FlexExport(ByVal Flex1 As MSHFlexGrid, ByVal CommonDialog1 As CommonDialog)
mvarVersion = vbLBV5
Dim SaveFilePath As String
Dim EXEString As String
Dim i As Integer, j As Integer
Dim InsertAmount As Integer
Dim WS As DAO.Workspace
Dim DB As DAO.Database
Dim TABL As DAO.TableDef
Dim RS As DAO.Recordset
'On Error GoTo err_handle
On Error Resume Next
With CommonDialog1
.CancelError = False
.Filter = "Excel文件(*.xls)|*.xls"
.DialogTitle = "将数据导出到Excel表(5.0)"
.ShowOpen
If Trim(.FileName) = "" Then
Exit Function
End If

SaveFilePath = .FileName
End With

Set WS = DBEngine.CreateWorkspace("WS", "Admin", "", dbUseJet)
Kill App.Path & "\report\FlexToExcel.mdb"
Set DB = WS.CreateDatabase(App.Path & "\report\FlexToExcel.mdb", dbLangGeneral, dbEncrypt)
Set TABL = DB.CreateTableDef("Excel")
For i = 1 To Flex1.Cols - 1
TABL.Fields.Append TABL.CreateField(Flex1.TextMatrix(0, i), dbText, 250)
Next i

DB.TableDefs.Append TABL
Set RS = DB.OpenRecordset("Excel")
If Flex1.Rows > 1 Then
InsertAmount = Flex1.Cols - 1
For i = 1 To Flex1.Rows - 1
RS.AddNew
For j = 1 To InsertAmount - 1
If Flex1.TextMatrix(i, j) <> "" Then
RS.Fields(j - 1) = Flex1.TextMatrix(i, j)
ElseIf Flex1.TextMatrix(i, j) = "" Then
RS.Fields(j - 1) = "//"
End If
Next j
RS.Update
Next i
End If
EXEString = "select * into [Excel " & Format(CStr(mvarVersion), "0.0") & ";database=" & SaveFilePath & "].LBExcel from Excel"
DB.Execute EXEString
RS.Close
DB.Close
WS.Close
Kill App.Path & "\report\FlexToExcel.mdb"
MsgBox "导出数据到Excel表成功!", vbInformation, "提示"
Exit Function
err_handle:
Select Case Err
Case 53:
Resume Next
End Select
End Function

[EricaNet]

其实思路都差不多，灵活掌握。
上面两段 都是 导出为文本，你要是导出为数字格式，可以在excel中汇总，可以参考这句。
TABL.Fields.Append TABL.CreateField(Flex1.TextMatrix(0, 10), dbDouble, 250) '职贴

[pancult]

Public Function ListviewExport(ByVal ListView1 As ListView, ByVal CommonDialog1 As CommonDialog)
mvarVersion = vbLBV5
Dim SaveFilePath As String
Dim EXEString As String
Dim i As Integer, j As Integer
Dim InsertAmount As Integer
Dim WS As DAO.Workspace
Dim DB As DAO.Database
Dim TABL As DAO.TableDef
Dim RS As DAO.Recordset
'On Error GoTo err_handle
On Error Resume Next
With CommonDialog1
.CancelError = False
.Filter = "Excel文件(*.xls)|*.xls"
.DialogTitle = "将数据导出到Excel表(5.0)"
.ShowOpen
If Trim(.FileName) = "" Then
Exit Function
End If

SaveFilePath = .FileName
End With
'If ListView1.ColumnHeaders.Count <= 0 Then
' Exit Sub
'End If


Set WS = DBEngine.CreateWorkspace("WS", "Admin", "", dbUseJet)
Kill App.Path & "\report\listviewToExcel.mdb"
Set DB = WS.CreateDatabase(App.Path & "\report\listviewToExcel.mdb", dbLangGeneral, dbEncrypt)
Set TABL = DB.CreateTableDef("Excel")
For i = 1 To ListView1.ColumnHeaders.Count
TABL.Fields.Append TABL.CreateField(ListView1.ColumnHeaders.Item(i).Text, dbText, 250)
Next i
DB.TableDefs.Append TABL
Set RS = DB.OpenRecordset("Excel")
If ListView1.ListItems.Count > 0 Then
If ListView1.ColumnHeaders.Count >= (ListView1.ListItems.Item(1).ListSubItems.Count + 1) Then
InsertAmount = ListView1.ListItems.Item(1).ListSubItems.Count + 1
Else
InsertAmount = ListView1.ColumnHeaders.Count
End If
For i = 1 To ListView1.ListItems.Count
RS.AddNew
If ListView1.ListItems.Item(i).Text <> "" Then
RS.Fields(0) = ListView1.ListItems.Item(i).Text
Else: RS.Fields(0) = "//"
End If
For j = 1 To InsertAmount - 1
If ListView1.ListItems.Item(i).ListSubItems.Item(j).Text <> "" Then
RS.Fields(j) = ListView1.ListItems.Item(i).ListSubItems.Item(j).Text
Else
RS.Fields(j) = "//"
End If
Next j
RS.Update
Next i
End If
EXEString = "select * into [Excel " & Format(CStr(mvarVersion), "0.0") & ";database=" & SaveFilePath & "].LBExcel from Excel"
DB.Execute EXEString
RS.Close
DB.Close
WS.Close
Kill App.Path & "\report\listviewToExcel.mdb"
MsgBox "导出数据到Excel表成功!", vbInformation, "提示"
Exit Function
err_handle:
Select Case Err
Case 53:
Resume Next
End Select

End Function

[cbzdream]

还有不？