根据搜索条件移动特定列

Question

Sub Test3()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 5
LSearchRow = 5

'Start copying data to row 2 in Sheet3 (row counter variable)
LCopyToRow = 2

While Len(Range("Y" & CStr(LSearchRow)).Value) > 0

    'If value in column Y = "84312570", copy entire row to Sheet3
    If Range("Y" & CStr(LSearchRow)).Value = "84312570" Then

        'Select row in MasterList to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy

        'Paste row into Sheet3 in next row
        Sheets("Sheet3").Select
        Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        ActiveSheet.Paste

        'Move counter to next row
        LCopyToRow = LCopyToRow + 1

        'Go back to MasterList to continue searching
        Sheets("MasterList").Select

    End If

    LSearchRow = LSearchRow + 1

Wend

'Position on cell A5
Application.CutCopyMode = False
Range("A5").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
    MsgBox "An error occurred."

End Sub

这会在 Y 列中查找特定值，并将相应信息的整行移动到各个工作表中。

我有两个问题。

首先，有没有办法指定仅将某些列的信息移动到各个工作表而不是移动整行？

其次，有没有办法仅根据 Y 列中数字序列的最后 4 位提取信息？例如，上面我想要提取 Y 列中的数字与 *2570 匹配的所有行。

Answer 1

未经测试：编辑 arrColsToCopy 以包含要复制的列

Sub Test3()

    Dim LCopyToRow As Long
    Dim LCopyToCol As Long
    Dim arrColsToCopy
    Dim c As Range, x As Integer

    On Error GoTo Err_Execute


    arrColsToCopy = Array(1, 2, 3, 5, 10, 15) 'which columns to copy ?
    Set c = Sheets("MasterList").Range("Y5") 'Start search in row 5
    LCopyToRow = 2  'Start copying data to row 2 in Sheet3

    While Len(c.Value) > 0

        'If value in column Y ends with "2570", copy to Sheet3
        If c.Value Like "*2570" Then

            LCopyToCol = 1
            For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)

                 Sheets("Sheet3").Cells(LCopyToRow, LCopyToCol).Value = _
                                c.EntireRow.Cells(arrColsToCopy(x)).Value

                LCopyToCol = LCopyToCol + 1

            Next x

            LCopyToRow = LCopyToRow + 1 'next row

        End If

        Set c = c.Offset(1, 0)

    Wend

    'Position on cell A5
    Range("A5").Select

    MsgBox "All matching data has been copied."

    Exit Sub

Err_Execute:
        MsgBox "An error occurred."

End Sub

Answer 2

^{首先，有没有办法指定仅将某些列的信息移动到各个工作表而不是移动整行？}

是的。您可以使用循环将列收集到 Union不连续范围对象或使用 交叉方法应用于所需列的预制范围。相交还可以应用于 xlCellTypeVisible 行应用 Range.AutoFilter 方法。

^{其次，有没有办法仅根据 Y 列中数字序列的最后 4 位提取信息？例如，上面我想提取 Y 列中的数字与 *2570 匹配的所有行。}

构建 Scripting.Dictionary 对象使用模式匹配来匹配键值，并使用字典的键作为 自动筛选，运算符参数为 < a href="https://msdn.microsoft.com/en-us/library/office/ff839625.aspx" rel="nofollow noreferrer">xlFilterValues。 Select Case 语句提供了简单的模式匹配方法。

Sub autoFilter_Intersect_Selected_Columns()
    Dim rngCols As Range, wsDEST As Worksheet, col As Range
    Dim c As Long, d As Long, dFLTR As Object, vARRs As Variant

    Set wsDEST = Worksheets("Sheet2")
    Set dFLTR = CreateObject("Scripting.Dictionary")

    With Worksheets("Sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False

        'set the 'stripes' of columns to be transferred
        Set rngCols = .Range("A:A, M:N, Q:R, Y:Y")
        'alternate
        Set rngCols = Union(.Columns(1), .Columns(13).Resize(, 2), _
                            .Columns(17).Resize(, 2), .Columns(25))

        With .Cells(1, 1).CurrentRegion
            'populate the dictionary keys with criteria values
            vARRs = .Columns(25).Cells.Value2
            For d = LBound(vARRs, 1) To UBound(vARRs, 1)
                Select Case True
                    Case vARRs(d, 1) Like "*2570"
                        'treat as strings in the key for the filter
                        dFLTR.Item(CStr(vARRs(d, 1))) = vARRs(d, 1)
                End Select
            Next d

            'apply the AutoFilter
            .Columns(25).AutoFilter Field:=1, Criteria1:=dFLTR.keys, _
                                    Operator:=xlFilterValues

            'copy the visible cells in the selected columns to the destination worksheet
            Intersect(rngCols, .SpecialCells(xlCellTypeVisible)).Copy _
                Destination:=wsDEST.Cells(1, 1)

            'fix the new .ColumnWidth(s) to the original
            For Each col In Intersect(rngCols, .Rows(1))
                c = c + 1
                wsDEST.Columns(c).EntireColumn.ColumnWidth = col.ColumnWidth
            Next col

        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With

    dFLTR.RemoveAll: Set dFLTR = Nothing
End Sub

循环填充、过滤和传输的过程可以轻松地循环遍历数组中的关联值。

       ^源数据

  
        ^{目的地结果}