根據搜索條件移動特定列

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

^{首先，有沒有指定的信息只有某些列的方式移動到各個片材，而不是移動整個的行？}

是的。您可以使用循環將列收集到不連續的Range objects的Union中，也可以將Intersect method應用於所需列的預先形成的範圍。 Intersect也可應用於來自應用Range.AutoFilter method的xlCellTypeVisible行。

^{其次，有沒有辦法根據Y列中的數字序列的最後4位提取信息？例如，上面我想要拉列Y中匹配* 2570的所有行。}

構建使用圖案匹配的匹配鍵值的Scripting.Dictionary對象，並使用字典的鍵作爲的AutoFilter標準陣列的xlFilterValues一個算參數。 A Select Case statement提供了簡單的模式匹配方法。

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 

自行車填充，過濾和轉移的過程中可以很容易地通過相關聯的值在陣列中循環。

^源數據

^{目的地導致}