亦有资源网

本文于2023年4月22日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！

☆本期内容概要☆

• ListView数据存入数组、导出到工作表
• 自定义函数获取文件夹路径
• 自定义函数判断是否存在指定名称的工作表（2种方法）

书接上回，关于使用ListVeiw控件制作科目汇总表，我们已经分享了多期内容：

Excel VBA 数据分析展示/ListView控件

Excel VBA 数据分析展示/ListView控件/Combox组合框控件/科目汇总表(2)

Excel VBA 数据分析展示/ListView控件/Combox组合框控件/CheckBox复选框控件/科目汇总表(3)

Excel VBA 数据分析展示/ListView控件/显示与隐藏控件/科目汇总表(4)

但是，仍旧没有结束，本期我们来做一个数据导出的功能：

1、点击“导出"，则导出listview的数据到Excel工作表。

2、根据导出按钮旁边的复选框，作出不同处理，可以选择文件夹保存，可以保存在当前Excel文件所在文件夹，也可以保存在当前Excel工作簿中。

增加几个控件，具体就不说了，类型前面都碰到过。

主要代码如下：

一、"导出"按钮CmdOutPut的Click事件：

Private Sub CmdOutPut_Click()
    Dim currLv As ListView
    Dim arrT()
    Dim iPath As String
    Dim tbName As String
    Dim Msg As String
    'On Error Resume Next
    If Not wContinue("即将导出！") Then Exit Sub
    If Not Me.CkbCurrentWB Then
        If Me.CkbChooseFolder Then
            iPath = PathSelected & "\"
        Else
            iPath = ThisWorkbook.Path & "\"
        End If
    End If
    Application.DisplayAlerts = False
    If Me.LvSum.Visible = True Then
        Set currLv = Me.LvSum
        tbName = "科目汇总表"
    Else
        Set currLv = Me.LvDetail
        tbName = "科目明细表"
    End If
    fName = tbName & Format(VBA.Now, "MMDDhhmmss") & ".xlsx"
    iRow = currLv.ListItems.Count + 1
    iCol = currLv.ColumnHeaders.Count
    ReDim arrT(1 To iRow, 1 To iCol)
    For i = 1 To iCol
        arrT(1, i) = currLv.ColumnHeaders(i)
    Next
    For i = 2 To iRow
        arrT(i, 1) = currLv.ListItems(i - 1).Text
        For j = 2 To iCol
            If Len(Trim(currLv.ListItems(i - 1).SubItems(j - 1))) = 0 Then
                arrT(i, j) = vbNullString
            Else
                arrT(i, j) = currLv.ListItems(i - 1).SubItems(j - 1)
            End If
        Next
    Next
     If Not Me.CkbCurrentWB Then
        Workbooks.Add
    End If
    With ActiveWorkbook
        If Not wbSheetExists(tbName) Then
            ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = tbName
        Else
            If Not wContinue("已存在" & tbName & "表，继续将覆盖！？") Then Exit Sub
            Sheets(tbName).Cells.Clear
         End If
        Sheets(tbName).Activate
        ActiveWorkbook.Sheets(tbName).Range("A3").Resize(iRow, iCol) = arrT
        Cells.Select
        Cells.EntireColumn.AutoFit
        Range("A1") = tbName
        Range("A1").Font.Size = 14
        With Range(Cells(1, 1), Cells(1, iCol))
            .Merge
            .HorizontalAlignment = xlHAlignCenter
         End With
         Range(Cells(3, 1), Cells(iRow + 2, iCol)).Borders.LineStyle = xlContinuous
      End With
      If Not Me.CkbCurrentWB Then
        ActiveWorkbook.SaveAs Filename:=iPath & fName
        ActiveWorkbook.Close
        Msg = "成功导出文件" & iPath & fName
    Else
        Msg = "成功导出工作表【" & tbName & "】"
    End If
    MsgBox Msg
    Unload Me
    Application.DisplayAlerts = True
End Sub

代码解析：

1、定义变量currLv as ListiView，主要原因是我们这里有两个listview，一个是科目汇总表（LvSum），一个是科目明细表（LvDetail），为了节省代码，我们把当前可见的listview赋给currLv，在大部分代码中，我们不用管它是LvSum还是LvDetail，具体运用可以参看代码。

2、定义数组arrT（），用来存放listview的内容，然后再一次性地把数据写入工作表，这里也可以不通过数组，而是直接使用循环给单元格赋值。

for i= 1 to listview1.listitems.count
    cells(i,1)=listview1.listitems(i).text
    for j=2 to listview1.colunmheaders.count
        cells(i,j)=listview1.listitems(i).subitems(j)
    next
next

上面的代码是我直接在这写的，没有测试，有可能有错，但意思就是这样。但如果数据量较大，这样的代码运行效率可能有点低。数据量少差别不大，但我还是喜欢使用数组，也建议在批量写入单格时，尽量使用数组。

3、定义其他变量，不细说了

4、使用自定义函数wContinue ，确认继续进行，否则退出程序，防止误操作。

Function wContinue(Msg) As Boolean
    '确认继续函数
    Dim Config As Long
    Dim a As Long
    Config = vbYesNo + vbDefaultButton2 + vbQuestion
    Ans = MsgBox(Msg & Chr(10) & "是(Y)继续?" & Chr(10) & "否(N)返回！", Config, "请确认操作！")
     wContinue = Ans = vbYes
End Function

这个自定义函数我们前面分享过：Excel VBA 继续执行？退出？确认

5、根据CkbChoosefolder的值，来确定文件保存位置。为True，则选择文件夹，iPath的值则为选择的文件夹，若为False，则为当前文件所在文件夹。这里用了一个获取文件路径的自定义函数：

Function PathSelected()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then   
            PathSelected = .SelectedItems(1)
        Else
            Exit Function
          End If
    End With
End Function

这个自定义函数前面也分享过：Excel VBA 文件批量改名/自定义函数获取文件夹路径/自定义函数获取文件夹下所有文件

6、根据当前显示的listview来确定currLv、tbName、fName的值。

7、根据currLv行列数来重定义arrT()，并通过循环把表头、明细记录写入数组arrT()。这里有个判断，想把值为0的记录替换为Null，似乎没有效果，但仍然选择留着它，也算一种处理问题的思路吧。如果确有强迫症看不得0的，可以在数据写入工作表后再处理它，

（1）可以设置成会计专用格式，0则变成“-”，看起来会顺眼很多。

（2）也可以把它替换为空。

（3）也可以把值0的单元格字体着色设置成背景色。

8、根据是否勾选了CkbCurrentWB，即保存在当前工作表，来确定是否新建工作表。

9、把arrT（）数据一次性写入名称为tbName的值的工作表，如果是保存在当前工作表，则还要判断一下是否存在同名的工作表，没有则添加，有则清除内容。这里用了一个自定义函数，判断是否存在指定名称的工作表：

Function wbSheetExists(ByVal strShtName As String) As Boolean
    Dim wkSht As Worksheet
    On Error Resume Next
    Set wkSht = Worksheets(strShtName)
    If Err.Number = 0 Then wbSheetExists = True
    Set wkSht = Nothing
End Function

说实话，这个函数是抄来的。也可以这样写（得换个名字）：

Function IsSheetExists(ByVal strShtName As String) As Boolean
    Dim wkSht As Worksheet
    Dim blnResult As Boolean
    For Each wkSht In ThisWorkbook.Worksheets
        If wkSht.Name = strShtName Then
            blnResult = True
            Exit For
        End If
    Next
    IsSheetExists = blnResult
End Function

这个自定义函数通过遍历工作表，比较工作表的名字与参数strShtName，如果相等，则说明存在此工作表，如果都比较完了，还是没有找到相等的结果，则说明不存在此工作表。我觉得从逻辑上来讲，第2种方法更清晰易懂一点。

10、对导入数据的工作表进行一些格式设置，标题行合并居中，字体增大，表体画线等。

11、最后，如果是新建工作簿的，则保存、关闭。

二、CkbChooseFolder、CkbCurrentWB两个控件的Change事件：

Private Sub CkbChooseFolder_Change()
    If CkbChooseFolder Then
        Me.CkbCurrentWB = False
    End If
End Sub


Private Sub CkbCurrentWB_Change()
 If CkbCurrentWB Then
        Me.CkbChooseFolder = False
    End If
End Sub

代码很简单，主要作用就是：这两个控件不能同时勾选，至于是为什么，逻辑大家想一想应该都能明白，就不啰嗦了。

三、另外，还修正了上期的一个小问题：如果点了复选框“一级科目"，但不点"查询“按钮，然后就双击LvSum，结果就不对了。很简单，给CkbLevelOne的change事件加一条代码，让它立即运行查询

Private Sub CkbLevelOne_Change()
    Call CmdQuery_Click
End Sub

其实，我们也可以把代码Call CmdQuery_Click加到CmbMonth的change事件中，点选立即更新，这个我们前面讲过。这样一来，查询按钮都有点多余。暂且先留着它吧，各位小伙伴可以自行处置。

好，今天就分享到这。有需要示例文件的小伙伴请点赞+留言，私信关键字"数据导出422"+邮箱吧，我们下期再会。

☆猜你喜欢☆

本文于2023年4月22日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！