如何将LISTVIEW中的数据导出到EXCEL?

Question

如何将LISTVIEW中的数据导出到EXCEL,含LISTVIEW中的数据和表头,求一个完整的过程

Answer 1

制作思路：
编制函数
private Function ExportListViewToExl(Lvw as ListView) as Boolean 
 On Error GoTo ErrorHandler
    
    Dim ExlApp As Object
    Dim ExlBook As Object
    Dim exlSheet As Object
    
    Dim filePath As String
    Dim CurRow As Integer
    Dim CurCol As Integer
    
    Dim I As Long, J As Long, K As Long
    
    Me.MousePointer = 11
    
    '* 是否有数据要打印
    If Me.ListView.ListCount <= 0 Then
        MsgBox "没有可打印的数据!", vbInformation, "提示信息"
        GoTo CleanExit
    End If
     
    filePath = App.Path & "\Report" & "\ModalName.xlt"
    
    If Dir(filePath) = "" Then
        MsgBox "找不到模板　（" & filePath & "） ！", vbInformation, "提示信息"
        GoTo CleanExit
    End If
    
    Set ExlApp = CreateObject("Excel.Application")
    ExlApp.Workbooks.Open (filePath)
    
    Set ExlBook = ExlApp.Workbooks(1)
    Set exlSheet = ExlBook.Worksheets(1)
    
    ExlApp.Visible = False
    
    With exlSheet
        '* 主档
         With lvw
             For I=0 To .ListCount '循环行
                 fOR J=1 TO .subItems.count‘循环列 
                    exlSheet.Cells(I,J)=.listItem(I).Subitems(j)’打印输出
                 next J   
             next j 
        End With
    End With
    
ShowExl:
    ExlApp.Visible = True
    
CleanExit:
    Me.MousePointer = 0
    Set ExlApp = Nothing
    Set ExlBook = Nothing
    Set exlSheet = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Description, vbInformation, "提示信息"
    GoTo CleanExitend Function

Answer 2

如果是连接数据库的话.我个人觉得一个个格式去写并不好,可以采用外部数据源的方式,理解成listview中的recordset导入.
可以参考下面这段代码:引用直接用 ExporToExcel strsql就可以了.下面包括列头设置,我个人觉得列头直接在sql语句中写好了,例如
strsql="select name as 姓名 from tablename"
Public Function ExporToExcel(strOpen As String)    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer    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 = Conn
        .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 = True    '添加查询语句，导入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
    '        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
    '        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
    '        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
    '        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
    '        .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
    '    End With
    '
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = NothingEnd Function

Answer 3

也可参考这段代码Public Function dhListviewToExcel( _
    ByRef lvw As MSComctlLib.ListView, _
    ByVal strFileName As String, _
    Optional FileFormat As XlFileFormat = xlWorkbookNormal, _
    Optional blnHeaders As Boolean = True) As Boolean
      
    
    Dim intColCnt                       As Integer          ' 列之計數器。
    Dim intColumns                      As Integer          ' 欄位數。
    Dim intRowCnt                       As Integer          ' 欄之計數器。
    Dim intStartRow                     As Integer          ' 開始列數。
    Dim intVisibleColumns()             As Integer          ' 表頭資料。
    
    Dim itm                             As ListItem
    
    Dim lngResults                      As Long             ' 回傳數值。
    
    Dim objExcel                        As Excel.Application
    Dim objWorkbook                     As Excel.Workbook
    Dim objWorksheet                    As Excel.Worksheet
    Dim objRange                        As Excel.Range
    
    Dim strArray()                      As String           ' 表身資料。
    Dim strFileExtensionType            As String           ' 延伸檔名。
    
    '------------------------------------------------
    ' A0 偵測作業。
    '------------------------------------------------
    ' 判斷 listview 是否有資料。
    If lvw.SelectedItem Is Nothing Then
        MsgBox "表格沒有任何資料。", vbOKOnly + vbInformation, "匯出失敗"
        GoTo ExitFunction
    End If
    
    ' 詢問使用者匯出範圍。
    lngResults = MsgBox("只匯出選擇列數之資料？", vbYesNoCancel + vbQuestion + vbDefaultButton2, "匯出選擇列數")
    
    If lngResults = vbCancel Then
        GoTo ExitFunction
    End If
    
    Screen.MousePointer = vbHourglass
    
    ' 測試是否本機是否安裝 Excel。
    On Error Resume Next
    Set objExcel = New Excel.Application
    
    If Err.Number > 0 Then
        MsgBox "本機未安裝 MS Excel 。", vbOKOnly + vbCritical, "載入 Excel 失敗"
        GoTo ExitFunction
    End If
    
    '------------------------------------------------
    ' B0 Excel 相關設定作業。
    '------------------------------------------------
    On Error GoTo ExportToExcel_EH
    
    ' 不讓使用者操作。
    objExcel.Interactive = False    ' 背後作業。
    If objExcel.Visible = False Then
        objExcel.Visible = True
    End If
    
    ' 視窗最大化。
    objExcel.WindowState = xlMaximized    ' 設定 Wokkbook 物件。
    Set objWorkbook = objExcel.Workbooks.Add
    
    ' 設定 Worksheet 物件，指向 Sheet 1。
    Set objWorksheet = objWorkbook.Sheets(1)
    
    ' 設定 Range 物件，指向 Row 1。
    Set objRange = objWorksheet.Rows(1)
    
    ' 設定表頭字型大小、粗體。
    objRange.Font.Size = 9
    objRange.Font.Bold = True
    
    '------------------------------------------------
    ' C0 Excel 表頭部份相關設定作業。
    '------------------------------------------------
    For intColCnt = 1 To lvw.ColumnHeaders.Count
        
        If lvw.ColumnHeaders(intColCnt).Width <> 0 Then            intColumns = intColumns + 1
            
            ReDim Preserve intVisibleColumns(1 To intColumns)
            
            intVisibleColumns(intColumns) = intColCnt
            
            objRange.Cells(1, intColumns) = lvw.ColumnHeaders(intColCnt).Text
            
            With objWorksheet.Columns(intColumns)
                
                Select Case LCase(lvw.ColumnHeaders(intColCnt).Tag)
                    Case "string", ""
                        .NumberFormat = "@"
                    Case "number"
                        .NumberFormat = "#,##0.00_);(#,##0.00)"
                        .HorizontalAlignment = xlRight
                    Case "date"
                        .NumberFormat = "yyyy/mm/dd"
                        .HorizontalAlignment = xlRight
                End Select
                
            End With
            
        End If
    Next intColCnt
    
    '------------------------------------------------
    ' D0 取得 listview 資料，置入陣列。
    '------------------------------------------------
    ReDim strArray(1 To lvw.ListItems.Count, 1 To intColumns)
    
    intStartRow = 2
    
    For Each itm In lvw.ListItems
       
        If lngResults = vbNo Or itm.Selected Then
            
            intRowCnt = intRowCnt + 1
            
            For intColCnt = 1 To intColumns
                
                If intVisibleColumns(intColCnt) = 1 Then
                    strArray(intRowCnt, 1) = itm.Text
                Else
                    strArray(intRowCnt, intColCnt) = itm.SubItems(intVisibleColumns(intColCnt) - 1)
                End If
            Next intColCnt
        End If
    Next itm    '------------------------------------------------
    ' E0 陣列資料，置入 Excel。
    '------------------------------------------------
    With objWorksheet
        .Range(.Cells(2, 1), .Cells(2 + intRowCnt - 1, intColumns)) = strArray
    End With
    
    objWorksheet.Columns.AutoFit
    
    '------------------------------------------------
    ' F0 取得延伸檔名。
    '    參閱 Excel 說明裡的「Microsoft Excel 提供的檔案格式轉換器」
    '------------------------------------------------
    Select Case FileFormat
        Case xlSYLK
            strFileExtensionType = "slk"
        Case xlWKS
            strFileExtensionType = "wks"
        Case xlWK1, xlWK1ALL, xlWK1FMT
            strFileExtensionType = "wk1"
        Case xlCSV, xlCSVMac, xlCSVWindows
            strFileExtensionType = "csv"
        Case xlDBF2, xlDBF3, xlDBF4
            strFileExtensionType = "dbf"
        Case xlWorkbookNormal, xlExcel2FarEast, xlExcel3, xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel7, xlExcel9795
            strFileExtensionType = "xls"
        Case xlHtml
            strFileExtensionType = "htm"
        Case xlTextMac, xlTextWindows, xlUnicodeText, xlCurrentPlatformText
            strFileExtensionType = "txt"
        Case xlTextPrinter
            strFileExtensionType = "prn"
        Case Else
            strFileExtensionType = "dat"
    End Select    '------------------------------------------------
    ' G0 另存檔案。
    '------------------------------------------------
    If InStr(1, strFileName, ".") = 0 Then
        
        ' 組合檔案名稱。
        strFileName = strFileName & "." & strFileExtensionType
        
        ' 另存檔案。
        objWorksheet.SaveAs strFileName, FileFormat
        
    End If
    
    '------------------------------------------------
    ' Z0 結束作業。
    '------------------------------------------------
    ' 關閉 Workbook。
    objWorkbook.Close
               
    ' 結束 Excel 作業。
    objExcel.Quit
          
    ' 載出物件變數。
    Set objRange = Nothing
    Set objWorksheet = Nothing
    Set objWorkbook = Nothing
    Set objExcel = Nothing
    
    ' 此處可以設定是否可以編輯 Excel。
'    objExcel.Interactive = True
    
    dhListviewToExcel = TrueExitFunction:    Screen.MousePointer = vbDefault
    
    Exit Function
    
ExportToExcel_EH:    ' 出現錯誤訊息。
    MsgBox "匯出失敗，原因如下：" & vbCrLf & vbCrLf & Err.Number & ": " & Err.Description, _
           vbOKOnly + vbCritical, "匯出失敗"
           
    ' 結束 Excel 作業。
    objExcel.Quit
          
    ' 載出物件變數。
    Set objRange = Nothing
    Set objWorksheet = Nothing
    Set objWorkbook = Nothing
    Set objExcel = Nothing
    
    GoTo ExitFunction
    
End Function

Answer 4

1楼您这个函数 包含LISTVIEW的每列标头吗

Answer 5

Public Sub Lv2Excel(ByVal lv As ListView)
    
    Dim iCurRow As Integer
    Dim iCurCol As Integer
    
    Dim ExcelApp As Object
    Dim xItem As ListItem
    
    On Error GoTo CatchErr
    
    '定义一个Excel对象
    Set ExcelApp = New Excel.Application
    
    With ExcelApp
        '
        .DisplayAlerts = False
    
        '创建一个新的工作簿
        .Workbooks.Add
    
        With .Sheets("Sheet1")
            '导入列标头
            For i = 0 To lv.ColumnHeaders.Count - 1
                .Cells(1, i + 1).Value = lv.ColumnHeaders(i).Text
            Next
            '设定数据其实行
            iCurRow = 2
            '逐格写入数据
            For Each xItem In lv.ListItems
                For i = 0 To lv.ColumnHeaders.Count - 1
                    Select Case i
                        Case 0
                            .Cells(iCurRow, i + 1).Value = xItem.Text
                        Case Else
                            .Cells(iCurRow, i + 1).Value = xItem.SubItems(i)
                    End Select
                Next
                iCurRow = iCurRow + 1
            Next
        End With
        '保存到指定的位置和文件名称
        .ActiveWorkbook.SaveAs 保存的路径文件名称, xlNormal
        '关闭对象
        .Quit
    End With
    
    Exit Sub
CatchErr:
    ExcelApp.Quit
    MsgBox Err.Description
End Sub

Answer 6

'如果在ListView中显示的表格可以通过一条SQL语句获得
'可以用以下办法,更简单
Public Sub Lv2Excel(ByVal lv As ListView)
    
    Dim rs As New ADODB.Recordset
    Dim ADOCN As New ADODB.Connection
    Dim ExcelApp As Object
    
    On Error GoTo CatchErr
    
    '创建一个ADO的Connection连接
    sConnStr = "连接字符串"
    If ADOCN.State = 1 Then ADOCN.Close
    ADOCN.ConnectionString = sConnStr
    ADOCN.CursorLocation = adUseClient
    ADOCN.Mode = adModeShareDenyNone
    ADOCN.ConnectionTimeout = 30
    ADOCN.Open
    
    '定义一个Excel对象
    Set ExcelApp = New Excel.Application
    
    With ExcelApp
        '
        .DisplayAlerts = False
    
        '创建一个新的工作簿
        .Workbooks.Add
        
        '获得一个ADO的Recordset的查询
        If rs.State = 1 Then rs.Close
        rs.Open "SQL查询语句", ADOCN, adOpenKeyset, adLockReadOnly
        Set rs.ActiveConnection = Nothing
        '将Recordset的查询直接导入到Excel对象中
        .Sheets("Sheet1").Range("A1:导出的列" & rs.RecordCount).CopyFromRecordset rs
        '保存到指定的位置和文件名称
        .ActiveWorkbook.SaveAs 保存的路径文件名称, xlNormal
        '关闭对象
        .Quit
    End With
    
    Exit Sub
CatchErr:
    ExcelApp.Quit
    MsgBox Err.Description
End Sub