ListView 复选框打勾的数据 另存为到同表新sheet

xiangye30520

求助，ListView 复选框打勾的数据 另存为到同表新sheet，如图片，选中序号1-8，通过按键 将此8条行数据+表头另存为新表，


之前发过（ ListView 复选框打勾的数据，修改完后，怎么同步到数据源）  xunanming老师给予了解答，非常感谢，这回另存为尝试了多次还是不行，求助大家，感谢！

3190496160

另存为到同表新sheet
不明白这句话是什么意思？？？？、

3190496160

Private Sub CommandButton5_Click()
Dim arr()
Dim rng As Range
ReDim arr(1 To 100000, 1 To 23)
If objListViewDemo1.ListItems.Count < 1 Then MsgBox "对不起!没有你想要导出的数据": Exit Sub
Set rng = ActiveSheet.Rows(1)
lj = CreateObject("wscript.shell").specialfolders.Item("desktop") & ("\")
For i = 1 To objListViewDemo1.ListItems.Count
    If objListViewDemo1.ListItems(i).Checked = True Then
        m = m + 1
        arr(m, 1) = objListViewDemo1.ListItems(i)
        For j = 1 To objListViewDemo1.ColumnHeaders.Count - 1
            arr(m, j + 1) = objListViewDemo1.ListItems(i).SubItems(j) '
        Next j
    End If
Next i
If m = "" Then MsgBox "请先勾选需要导出的数据！": Exit Sub
Application.SheetsInNewWorkbook = 1
Set wb = Workbooks.Add
With wb.Worksheets(1)
    rng.Copy .[a1]
    .[a2].Resize(m, UBound(arr, 2)) = arr
    For Each sp In .Shapes
        sp.Delete
    Next sp
    .Columns("a:w").AutoFit
    .UsedRange.Borders.LineStyle = 1
End With
wb.SaveAs Filename:=lj & "导出文件" & Format(Date, "yyyymmdd") & ".xlsx"
wb.Close
MsgBox "导出完毕！", 0, "提醒"
End Sub

3190496160

test2.rar (65.83 KB, 下载次数: 17)

2024-7-19 09:48 上传

点击文件名下载附件

3190496160

目前的代码，是导出一个新的文件到桌面，供参考

Qs18

Private Sub CommandButton5_Click()
    Dim ListView As Object
    Dim Item As Object
    Dim ws As Worksheet
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim checkedItemsCount As Integer
    Set ListView = Me.objListViewDemo1
    Set ws = ThisWorkbook.Worksheets.Add
    checkedItemsCount = 0
    For Each Item In ListView.ListItems
        If Item.Checked Then
            checkedItemsCount = checkedItemsCount + 1
        End If
    Next Item
    If checkedItemsCount = 0 Then Exit Sub
    Dim headers() As String
    ReDim headers(1 To ListView.ColumnHeaders.Count)
    For i = 1 To ListView.ColumnHeaders.Count
        headers(i) = ListView.ColumnHeaders.Item(i).Text
    Next i
    ws.Cells(1, 1).Resize(1, UBound(headers) + 1).Value = headers
    k = 2 ' 工作表起始行
    For Each Item In ListView.ListItems
        If Item.Checked Then
            For j = 1 To ListView.ColumnHeaders.Count
                ws.Cells(k, j).Value = Item.Text
            Next j
            k = k + 1
        End If
    Next Item
End Sub

Qs18

是否可以........

心的启点

练练手，再不练都不会写代码了。

test.rar (45.43 KB, 下载次数: 11)

2024-7-19 10:57 上传

点击文件名下载附件

xiangye30520

3190496160 发表于 2024-7-19 09:47
Private Sub CommandButton5_Click()
Dim arr()
Dim rng As Range

非常感谢老师！问题已解决