VBA 筛选表并将结果列的子集复制到剪贴板

Question

我正在尝试将源表中的行和列的子集自动复制到剪贴板中，以便在其他应用程序中使用。我正在表的标题上创建过滤器并正确过滤行，但不知道如何按我想要的顺序选择列的子集。源表是 A - L 列，我想在应用过滤器后按顺序将 C、I、H 和 F 列复制到剪贴板。下面包含一些代码(减去复制部分)。

Sub exportExample()
    Dim header As Range
    Dim srcCol As Range

    Set header = [A5:L5]

    header.AutoFilter
    header.AutoFilter 12, "Example", xlFilterValues

    'Copy out columns C, I, H and F of the resulting table in that order
End Sub

我可以弄清楚如何复制列，但不知道如何按照我想要的顺序获取它们。任何帮助是极大的赞赏!谢谢!

Answer 1

这是你正在尝试的吗？我已经对代码进行了注释，以便您理解它不会有任何问题。

逻辑 :

过滤数据

创建临时表

将过滤后的数据复制到临时表

删除不必要的列(A、B、D、E、G、J、K、L)

将相关列(C、F、H、I)重新排列为 C、I、H 和 F

最后删除Temp Sheet(IMP:阅读代码末尾的注释)

代码(久经考验)

Option Explicit

Sub Sample()
    Dim ws As Worksheet, wsTemp As Worksheet
    Dim rRange As Range, rngToCopy As Range
    Dim lRow As Long

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Get the Last Row
        lRow = .Range("L" & .Rows.Count).End(xlUp).Row

        '~~> Set your range for autofilter
        Set rRange = .Range("A5:L" & lRow)

        '~~> Remove any filters
        .AutoFilterMode = False

        '~~> Filter, copy visible rows to temp sheet
        With rRange
            .AutoFilter Field:=12, Criteria1:="Example"

            '~~> This is required to get the visible range
            ws.Rows("1:4").EntireRow.Hidden = True

            Set rngToCopy = .SpecialCells(xlCellTypeVisible).EntireRow

            Set wsTemp = Sheets.Add

            rngToCopy.Copy wsTemp.Range("A1")

            '~~> Unhide the rows
            ws.Rows("1:4").EntireRow.Hidden = False
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With

    '~~> Re arrange columns in Temp sheet so that we get C, I, H and F
    With wsTemp
        .Range("A:B,D:E,G:G,J:L").Delete Shift:=xlToLeft
        .Columns("D:D").Cut
        .Columns("B:B").Insert Shift:=xlToRight
        .Columns("D:D").Cut
        .Columns("C:C").Insert Shift:=xlToRight

        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        Set rngToCopy = .Range("A1:D" & lRow)

        Debug.Print rngToCopy.Address

        '~~> Copy the range to clipboard
        rngToCopy.Copy
    End With

    'NOTE
    '
    '~~> Once you have copied the range to clipboard, do the necessary
    '~~> actions and then delete the temp sheet. Do not delete the
    '~~> sheet before that. An alternative would be to use the APIs
    '~~> to place the range in the clipboard so you can safely delete
    '~~> the sheet before performing any actions. This will not clear
    '~~> clear the range if the sheet is immediately deleted.
    '
    '

    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True
End Sub

屏幕截图

代码运行前的 Sheet1



带有过滤数据的临时表



跟进

要删除边框，您可以将此代码添加到上面的代码中

With rngToCopy
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
end with

将上面的代码放在 Debug.Print rngToCopy.Address 行之后