只导出需要的行

hhxq001

想导出打√的各行数据和表头，怎么实现呀

选择性导出求助.rar (17.55 KB, 下载次数: 8)

2022-5-26 17:58 上传

点击文件名下载附件

心正意诚身修

筛选一下不就完了么？

sam-wang

請測試看看，謝謝
Sub test()
Dim Arr, Brr, i&, j%, n&
Arr = Sheet2.[a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To 8)
For i = 1 To UBound(Arr)
    If Arr(i, 8) <> "" Then
        n = n + 1: For j = 1 To 8: Brr(n, j) = Arr(i, j): Next
    End If
Next
Workbooks.Add
Sheets(1).[a1].Resize(n, 8) = Brr
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "D:\test.xls"
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub

hhxq001

sam-wang 发表于 2022-5-26 20:03
請測試看看，謝謝
Sub test()
Dim Arr, Brr, i&, j%, n&

这样确实可以导出需要的行，但是没有了原表的格式，有点美中不足呢

sam-wang

hhxq001 发表于 2022-5-26 22:22
这样确实可以导出需要的行，但是没有了原表的格式，有点美中不足呢

保有原格式，請再測試看看，謝謝

Sub test()
Dim WB, fileOrg
Application.ScreenUpdating = False: Application.DisplayAlerts = False
fileOrg = ActiveWorkbook.Name
Set WB = Workbooks.Add
WB.SaveAs "D:\test.xls"
Windows(fileOrg).Activate
With Sheets(1)
    If .FilterMode Then .ShowAllData
    With Range("A1").CurrentRegion
        .AutoFilter 8, "><" & " "
        .SpecialCells(xlCellTypeVisible).Copy WB.Sheets(1).[a1]
        .AutoFilter
    End With
End With
WB.Close 1
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

hhxq001

sam-wang 发表于 2022-5-27 10:26
保有原格式，請再測試看看，謝謝

Sub test()

唯一不足，导出后d1单元格的合计是原表的合计，不是生成的新表的合计。

sam-wang

hhxq001 发表于 2022-5-28 12:27
唯一不足，导出后d1单元格的合计是原表的合计，不是生成的新表的合计。

生成的新表的合计
>>已更新如下紅字，請再測試看看，謝謝
Sub test()
Dim Arr, WB, i&, s
Application.ScreenUpdating = False: Application.DisplayAlerts = False
fileorg = ActiveWorkbook.Name
Set WB = Workbooks.Add
WB.SaveAs "D:\test.xls"
Windows(fileorg).Activate
With Sheets(1)
    If .FilterMode Then .ShowAllData
    With Range("A1").CurrentRegion
        .AutoFilter 8, "><" & " "
        .SpecialCells(xlCellTypeVisible).Copy WB.Sheets(1).[a1]
        .AutoFilter
    End With
End With
WB.Activate
Arr = [a1].CurrentRegion
For i = 2 To UBound(Arr): s = s + Arr(i, 4): Next
[d1] = "Price" & Chr(10) & s
WB.Close 1
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

金樽空对月

详见附件