根据搜索条件移动特定列

发布于 2024-12-03 18:43:56 字数 1304 浏览 3 评论 0原文

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 匹配的所有行。

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

This finds specific values in Column Y and moves entire rows of corresponding information to individual worksheets.

I have two questions.

First, is there a way to specify only certain columns of information be moved to the individual sheets instead of moving the entire row?

Second, is there a way to pull information based off of only the last 4 digits of the number sequence in column Y? For example, above I would want to pull all rows whose number in column Y matched *2570.

如果你对这篇内容有疑问,欢迎到本站社区发帖提问 参与讨论,获取更多帮助,或者扫码二维码加入 Web 技术交流群。

扫码二维码加入Web技术交流群

发布评论

需要 登录 才能够评论, 你可以免费 注册 一个本站的账号。

评论(2

樱花坊 2024-12-10 18:43:56

未经测试:编辑 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

Untested: edit arrColsToCopy to include the columns you want copied over

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
凉城已无爱 2024-12-10 18:43:56

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

是的。您可以使用循环将列收集到 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

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

filter_Copy_Selected_Columns
       源数据

  filter_Copy_Selected_Columns_Results
        目的地结果

First, is there a way to specify only certain columns of information be moved to the individual sheets instead of moving the entire row?

Yes. You can use a loop to collect the columns into a Union of discontiguous Range objects or sweep them with an Intersect method applied against a preformed range of the desired columns. The Intersect can also be applied against the xlCellTypeVisible rows from an applied Range.AutoFilter method.

Second, is there a way to pull information based off of only the last 4 digits of the number sequence in column Y? For example, above I would want to pull all rows whose number in column Y matched *2570.

Build a Scripting.Dictionary object of the matching key values using a pattern match and use the dictionary's keys as the array of criteria of AutoFilter with an Operator parameter of xlFilterValues. A Select Case statement provides easy pattern matching methods.

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

Cycling the process of populating, filtering and transferring could easily be looped through associated values in an array.

  filter_Copy_Selected_Columns
        Source data

  filter_Copy_Selected_Columns_Results
        Destination results

~没有更多了~
我们使用 Cookies 和其他技术来定制您的体验包括您的登录状态等。通过阅读我们的 隐私政策 了解更多相关信息。 单击 接受 或继续使用网站,即表示您同意使用 Cookies 和您的相关数据。
原文