根据search条件移动特定列

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列中find特定的值，并将整行对应的信息移动到单个工作表中。

我有两个问题。

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

其次，有没有一种方法可以根据Y列中的数字序列的最后四位数来提取信息？ 例如，上面我想要拉列Y中匹配* 2570的所有行。

Answer 1

未经testing：编辑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

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

是。 您可以使用循环将列收集到不连续的Range对象的联合中 ，也可以使用针对所需列的预先形成的范围应用Intersect方法对它们进行清除。 相交也可以应用于来自应用的Range.AutoFilter方法的xlCellTypeVisible行。

^{其次，有没有一种方法可以根据Y列中的数字序列的最后四位数来提取信息？ 例如，上面我想要拉列Y中匹配* 2570的所有行。}

使用模式匹配构build匹配键值的Scripting.Dictionary对象，并使用字典的键作为具有xlFilterValues的运算符参数的AutoFilter条件数组。 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 

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

^源数据

^{目的地结果}