如何将listview中的内容倒出到excel（要求对应各列宽度一致）？

用友有一个excel读写控件，功能强大，不妨一试。

单位不对，listview的好象是像素，excel中的是磅，用scale或excel中的一个函数换一下。

使用VBA，肯定可实现，你可以参考有关书籍，在此给你个grid导出到excel的通用函数，你可以参考一下，这可是我的力作，但有些慢。Function ExcelOutPut(Commondlg As CommonDialog, Count As Integer, grid As Variant, intStartCol As Integer, Optional Enprgrs As Boolean, Optional FrmPrg As Form, Optional MergeTitle As Boolean, Optional append As Boolean = False, Optional Titles As _
Variant, Optional Count2 As Integer, Optional Count3 As Integer, Optional Border As Boolean = True, Optional Bordercolor As _
Integer = -4105, Optional Colwidth As Integer, Optional Autocolwidth As Boolean = True, Optional Bgcolor As Integer, Optional Formatnum As Integer) As Boolean'''''''''参数说明'''''''''
'Append:是否追加
'Commondlg:通用对话框
'Count:要导出的Grid数组元素数
'Grid:要导出的Grid数组
'Titles:标题数组
'Count2:之前为标题,之后为尾注
'Count3:数组Titles的二维宽度
'Border:是否有边框
'Bordercolor:边框颜色
'Colwidth:列宽
'Autocolwidth:自动设置列宽
'Bgcolor:背景颜色
'Enprgrs:是否有进度条
'FrmPrg:带有进度条的窗体
'MergeTitle:合并标题
'FormatNum:格式化数值型数据
''''''''''''''''''''''''''
Dim num As Integer '工作簿中的工作表数
Dim Start As Integer '要填写的工作表的开始编号
Dim EndStart As Integer '要填写的工作表的结束编号
Dim Counter As Integer '计数器,用于访问控件数组,从0开始
Dim Col As Long 'grid的列数
Dim Row As Long 'grid的行数
Dim FixRow As Integer
Dim i As Long '用于访问grid的行
Dim j As Long '用于访问grid的列
Dim T As Integer
Dim M As Integer
Dim n As Integer
Dim Selected As Integer '默认的当前工作表
Dim StartRow As Integer '工作表中开始的行号
Dim Rngstr As String '范围字符串
Dim Ex As Object 'Excel应用对象
Dim newbook As Workbook 'Excel工作簿
Dim Tmpgrid() As Object
Dim X As Integer
Dim Y As String
Dim Counts As Integer    On Error GoTo ErrProcess


    ReDim Tmpgrid(Count - 1)
    If Count = 1 Then
        Set Tmpgrid(0) = grid
    Else
        For i = 0 To Count - 1
            Set Tmpgrid(i) = grid(i)
        Next i
    End If

    '默认开始行号为1
    StartRow = 1

    '设置通用对话框
    Commondlg.FileName = ""
    Commondlg.Filter = "Microsoft Excel 工作簿|*.xls"

    If Not append Then
        Commondlg.ShowSave
    Else
        Commondlg.ShowOpen
    End If

    '如果没有选择文件,则退出
    If Commondlg.FileName = "" Then Exit Function

    If Dir(Commondlg.FileName) <> "" Then
        FileStr = Commondlg.FileName
        Frm_option.Show 1
        If FileStr = "true" Then
            append = True
        End If
    End If

    Set Ex = CreateObject("Excel.Application")
    '默认为1个工作表
    Ex.SheetsInNewWorkbook = 1

    If Not append Then '新建
        If Dir(Commondlg.FileName) <> "" Then Kill Commondlg.FileName
        Set newbook = Ex.Workbooks.Add
        newbook.SaveAs FileName:=Commondlg.FileName
    Else               '追加
        If Dir(Commondlg.FileName) = "" Then
            If MsgBox("文件'" & Commondlg.FileName & "'不存在,是否新建?", vbInformation + vbYesNo) = vbYes Then
                Set newbook = Ex.Workbooks.Add
                newbook.SaveAs FileName:=Commondlg.FileName
                append = False
            Else
                Exit Function
            End If
        End If
    End If

    Set newbook = Ex.Workbooks.Open(Commondlg.FileName)
    num = Ex.Sheets.Count

    '设置从那个工作表开始填写
    If append Then
        Start = num + 1
        Ex.Sheets.Add , Ex.Sheets(Ex.Sheets.Count)
    Else
        Start = num
    End If
    EndStart = Start + Count - 1

    '设置第一个开始填写的工作表为默认工作表
    Selected = Start

    '将grid中的内容添入到Excel中
    For Start = Start To EndStart
        Col = Tmpgrid(Counter).Cols - 1
        Row = Tmpgrid(Counter).Rows - 1
        FixRow = Tmpgrid(Counter).FixedRows

        If VarType(Titles) = 8200 Then
            StartRow = StartRow + Count2 '开始行号为2
        End If

        '---初始化进度条
        If Enprgrs Then   '====Modify By Liul====
            FrmPrg.Width = frmMain.StatusBar1.Panels(1).Width - 10
            FrmPrg.Height = frmMain.StatusBar1.Height - 70
            FrmPrg.Top = frmMain.Top + frmMain.Height - frmMain.StatusBar1.Height - 10
            FrmPrg.Left = frmMain.StatusBar1.Left
            FrmPrg.Show

            FrmPrg.prgOperation.Left = 10
            FrmPrg.prgOperation.Top = 5
            FrmPrg.prgOperation.Width = FrmPrg.Width - 10
            FrmPrg.prgOperation.Height = FrmPrg.Height


            FrmPrg.prgOperation.Visible = True
            FrmPrg.prgOperation.Max = (Col + 1) * (Row + 1)
            FrmPrg.prgOperation.Value = 0
        End If

        Screen.MousePointer = vbHourglass
        M = 0
        For i = 0 To Row

            If Tmpgrid(Counter).RowHeight(i) > 10 Then
                n = 0
                T = 0
                For j = intStartCol To Col    '====Modify By Liul====

                    If Tmpgrid(Counter).Colwidth(j) > 10 Then

                        Rngstr = Trim(Chr(65 + n Mod 26)) & Trim(str(M + StartRow))
                        If T <> 0 Then Rngstr = Trim(Chr(65 + T - 1)) & Rngstr
                        T = (n + 1) \ 26
                        Ex.Sheets(Start).Range(Rngstr).Font.Size = 10
                        Ex.Sheets(Start).Range(Rngstr) = Tmpgrid(Counter).TextMatrix(i, j)

                        n = n + 1
                        If i < FixRow Then
                            Ex.Sheets(Start).Range(Rngstr).Select

                            Ex.Selection.HorizontalAlignment = xlCenter
                            Ex.Selection.Font.Bold = False
                            Ex.Selection.Font.Size = 10

'                            Ex.Selection.WrapText = True
                        End If
                        If Formatnum <> 0 And Formatnum <= j Then
                            Ex.Sheets(Start).Range(Rngstr).NumberFormatLocal = "#,##0.00"
                            Ex.Sheets(Start).Range(Rngstr).Font.Size = 10
                        End If
                    End If

                    If Enprgrs Then FrmPrg.prgOperation.Value = FrmPrg.prgOperation.Value + 1

                Next j
                M = M + 1
            Else
                If Enprgrs Then FrmPrg.prgOperation.Value = FrmPrg.prgOperation.Value + Col
            End If
        Next i


        If Enprgrs Then
            FrmPrg.prgOperation.Value = FrmPrg.prgOperation.Max

            FrmPrg.prgOperation.Visible = False
            FrmPrg.Hide
            Unload FrmPrg
        End If

'合并表头
        If MergeTitle Then            For i = 0 To FixRow - 1
                X = intStartCol
                Y = Tmpgrid(Counter).TextMatrix(i, intStartCol)
                Counts = 0
                For j = intStartCol + 1 To Col
                    If (Tmpgrid(Counter).TextMatrix(i, j) <> Y And j <> Col) Or (j = Col And Tmpgrid(Counter).TextMatrix(i, j) = Y) Or (Titles(0, 1) = "^朝阳区农村公有经济资资产负债过录汇总表（二）" And j = 13) Then
                        If j = Col Then
                            Rngstr = IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & _
                            Trim(Chr(65 + Counts Mod 26)) & Trim(str(StartRow + i))
                            Ex.Sheets(Start).Range(Rngstr).ClearContents                            Rngstr = IIf(X \ 26 > 0, Trim(Chr(65 + X \ 26 - 1)), "") & Trim(Chr(65 + X Mod 26)) & _
                            Trim(str(StartRow + i)) & ":" & IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & _
                            Trim(Chr(65 + Counts + 1 Mod 26)) & Trim(str(StartRow + i))
                            Ex.Sheets(Start).Range(Rngstr).Merge
                        Else
                            If j - X > 1 Then
                                Rngstr = IIf(X \ 26 > 0, Trim(Chr(65 + X \ 26 - 1)), "") & Trim(Chr(65 + X Mod 26)) & _
                                Trim(str(StartRow + i)) & ":" & IIf((Counts) \ 26 > 0, Trim(Chr(65 + (Counts) \ 26 - 1)), "") & _
                                Trim(Chr(65 + (Counts) Mod 26)) & Trim(str(StartRow + i))
                                Ex.Sheets(Start).Range(Rngstr).Merge
                            End If
                            X = j
                            Y = Tmpgrid(Counter).TextMatrix(i, j)
                        End If
                    '清空
                    Else
                        If j <> Col Then
                            Rngstr = IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & _
                            Trim(Chr(65 + Counts Mod 26)) & Trim(str(StartRow + i))
                            Ex.Sheets(Start).Range(Rngstr).ClearContents
                        End If
                    End If
                    Counts = Counts + 1
                Next j
            Next i

            '逐列扫描
            Counts = 0
            If FixRow > 1 Then
                For j = intStartCol To Col
                    X = 0
                    Y = Tmpgrid(Counter).TextMatrix(0, j)
                    For i = 1 To FixRow - 1
                        If (Tmpgrid(Counter).TextMatrix(i, j) <> Y And i <> (FixRow - 1)) Or (i = (FixRow - 1) And Tmpgrid(Counter).TextMatrix(i, j) = Y) Then
                            If i = FixRow - 1 Then
                                Rngstr = IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & _
                                Trim(Chr(65 + Counts Mod 26)) & Trim(str(StartRow + i))
                                Ex.Sheets(Start).Range(Rngstr).ClearContents

                                Rngstr = IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & Trim(Chr(65 + Counts Mod 26)) & _
                                Trim(str(StartRow + X)) & ":" & IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & _
                                Trim(Chr(65 + Counts Mod 26)) & Trim(str(StartRow + i))
                                Ex.Sheets(Start).Range(Rngstr).Merge
                                Ex.Sheets(Start).Range(Rngstr).VerticalAlignment = xlCenter
                            Else
                                If i - X > 1 Then
                                    Rngstr = IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & Trim(Chr(65 + Counts Mod 26)) & _
                                    Trim(str(StartRow + X)) & ":" & IIf((Counts) \ 26 > 0, Trim(Chr(65 + (Counts) \ 26 - 1)), "") & _
                                    Trim(Chr(65 + (Counts) Mod 26)) & Trim(str(StartRow + i - 1))
                                    Ex.Sheets(Start).Range(Rngstr).Merge
                                    Ex.Sheets(Start).Range(Rngstr).VerticalAlignment = xlCenter
                                End If
                                X = i
                                Y = Tmpgrid(Counter).TextMatrix(i, j)
                            End If
                        '清空
                        Else
                            If i <> FixRow - 1 Then
                                Rngstr = IIf(Counts \ 26 > 0, Trim(Chr(65 + Counts \ 26 - 1)), "") & _
                                Trim(Chr(65 + Counts Mod 26)) & Trim(str(StartRow + i))
                                Ex.Sheets(Start).Range(Rngstr).ClearContents
                            End If
                        End If
                    Next i
                    Counts = Counts + 1
                Next j
            End If
        End If

        '设置标题
        If VarType(Titles) = 8200 Then
            For i = 1 To Count2
                Ex.Sheets(Start).Range("A" & Trim(str(i))) = Right(Titles(Counter, i), Len(Titles(Counter, i)) - 1)
                Rngstr = "A" & Trim(str(i)) & ":" & IIf((n - 1) \ 26 > 0, Trim(Chr(65 + (n - 1) \ 26 - 1)), "") & _
                Trim(Chr(65 + (n - 1) Mod 26)) & Trim(str(i))
                Ex.Sheets(Start).Range(Rngstr).Select
                Select Case Left(Titles(Counter, i), 1)
                    Case "<"
                        Ex.Selection.HorizontalAlignment = xlLeft
                    Case "^"
                        Ex.Selection.HorizontalAlignment = xlCenter
                    Case ">"
                        Ex.Selection.HorizontalAlignment = xlRight
                End Select
                Ex.Selection.Merge
                If i = 1 Then Ex.Selection.Font.Bold = True
            Next i
            j = 0
            For i = i To Count3
                Ex.Sheets(Start).Range("A" & Trim(str(StartRow + M + j))) = Right(Titles(Counter, i), Len(Titles(Counter, i)) - 1)
                Rngstr = "A" & Trim(str(StartRow + M + j)) & ":" & IIf((n - 1) \ 26 > 0, Trim(Chr(65 + (n - 1) \ 26 - 1)), "") & _
                Trim(Chr(65 + (n - 1) Mod 26)) & Trim(str(StartRow + M + j))
                Ex.Sheets(Start).Range(Rngstr).Select
                Select Case Left(Titles(Counter, i), 1)
                    Case "<"
                        Ex.Selection.HorizontalAlignment = xlLeft
                    Case "^"
                        Ex.Selection.HorizontalAlignment = xlCenter
                    Case ">"
                        Ex.Selection.HorizontalAlignment = xlRight
                End Select
                Ex.Selection.Merge
                j = j + 1
            Next i
        End If

'设置边框
        If Border Then
            Rngstr = "A" & Trim(str(StartRow)) & ":" & IIf((n - 1) \ 26 > 0, Trim(Chr(65 + (n - 1) \ 26 - 1)), "") & _
            Trim(Chr(65 + (n - 1) Mod 26)) & Trim(str(StartRow + M - 1))
            Ex.Sheets(Start).Range(Rngstr).Select
            With Ex.Selection.Borders(xlEdgeLeft)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = Bordercolor
            End With
            With Ex.Selection.Borders(xlEdgeTop)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = Bordercolor
            End With
            With Ex.Selection.Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = Bordercolor
            End With
            With Ex.Selection.Borders(xlEdgeRight)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = Bordercolor
            End With
            With Ex.Selection.Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = Bordercolor
            End With
            With Ex.Selection.Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = Bordercolor
            End With
        End If

        If Bgcolor <> 0 Then
            Rngstr = "A" & Trim(str(StartRow)) & ":" & IIf((n - 1) \ 26 > 0, Trim(Chr(65 + (n - 1) \ 26 - 1)), "") & _
            Trim(Chr(65 + (n - 1) Mod 26)) & Trim(str(StartRow + M - 1))
            Ex.Sheets(Start).Range(Rngstr).Select
            Ex.Selection.Interior.ColorIndex = Bgcolor
        End If

        Rngstr = "A:" & IIf((n - 1) \ 26 > 0, Trim(Chr(65 + (n - 1) \ 26 - 1)), "") & _
        Trim(Chr(65 + (n - 1) Mod 26))

        '统一列宽
        If Colwidth <> 0 Then
            Ex.Sheets(Start).Columns(Rngstr).ColumnWidth = Colwidth
        End If

        '自动设置列宽
        If Autocolwidth And Colwidth = 0 Then
            Ex.Sheets(Start).Columns(Rngstr).EntireColumn.AutoFit
        End If

        Counter = Counter + 1
        '把焦点设置在标题右方
        'Rngstr = IIf((n - 1) \ 26 > 0, Trim(Chr(65 + (n - 1) \ 26 - 1)), "") & Trim(Chr(65 + n Mod 26)) & "1"
        '把焦点设置在标题上
        Rngstr = "A1"
        Ex.Sheets(Start).Range(Rngstr).Select
        If Start <> EndStart Then Ex.Sheets.Add , Ex.Sheets(Ex.Sheets.Count)
    Next Start

    '选择第一个工作表为默认当前工作表
    Ex.Sheets(Selected).Select
    newbook.Save

    '关闭工作簿
    newbook.Close False
    Set newbook = Nothing
    Ex.Quit
    ExcelOutPut = True
    Screen.MousePointer = vbDefault
    Exit Function
ErrProcess:

    Select Case Err.Number
    Case 75
        MsgBox "错误" & Err.Number & ":" & Err.Description, vbCritical
        Ex.Quit
    Case 1004
        Resume Next
    Case -2147417851
        Resume Next
    End Select
    Screen.MousePointer = vbDefault
    Exit Function
End Function
函数太长，分开回复的

调试易

如何将listview中的内容倒出到excel（要求对应各列宽度一致）？

解决方案 »