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不连续的Range objects中，或者使用针对预定范围的所需列的Intersect method进行扫描。也可以对应用的xlCellTypeVisible中的Range.AutoFilter method行应用“相交”。

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

使用模式匹配构建匹配键值的Scripting.Dictionary对象，并使用字典的键作为AutoFilter条件的数组，其中运算符参数为{{ 3}}。 xlFilterValues提供了简单的模式匹配方法。

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

循环填充，过滤和传输过程很容易通过数组中的关联值循环。

Select Case statement
^源数据

^{目的地结果}

根据搜索条件移动特定列

2 个答案: