複数の条件のセルを見つけて同じシートを別のシートに貼り付ける（簡体字）

Question

複数の条件でセルを見つけ、別のシートに貼り付ける以下のコードを固定するための代替案または提案。

Sub test() 
    'For Move Entire Row to New Worksheet if Cell Contains Specific Text's 
    'Using autofilter to Copy rows that contain certain text to a sheet called commodity 
    Dim LR As Long 
    Range("A2").EntireRow.Insert Shift:=xlDown 
    LR = Sheets("Data").Cells(Rows.Count, "E").End(xlUp).Row 
    LR1 = Sheets("Commodity").Cells(Rows.Count, "A").End(xlUp).Row + 1 

    With Sheets("Data").Range("e:e") 
    .AutoFilter Field:=1, Criteria1:=("*SILVER*") 
    .SpecialCells(xlCellTypeVisible).EntireRow.Copy 
    Destination:=Sheets("Commodity").Range("A" & LR1) 
    .SpecialCells(xlCellTypeVisible).EntireRow.Delete 
    End With 

    With Sheets("Data").Range("e:e") 
    .AutoFilter Field:=1, Criteria1:=("*GOLD*") 
    .SpecialCells(xlCellTypeVisible).EntireRow.Copy 
    Destination:=Sheets("Commodity").Range("A" & LR1) 
    .SpecialCells(xlCellTypeVisible).EntireRow.Delete 
    End With 

    With Sheets("Data").Range("e:e") 
    .AutoFilter Field:=1, Criteria1:=("*MCX*") 
    .SpecialCells(xlCellTypeVisible).EntireRow.Copy 
    Destination:=Sheets("Commodity").Range("A" & LR1) 
    .SpecialCells(xlCellTypeVisible).EntireRow.Delete 
    End With 

End Sub 

Answer 1

だけでなく、Excelの機能とインターフェイスを持つ、これをされる減速何あなたの繰り返しの相互作用をしている@ShaiRado良い提案など。理想的には、データをVBA内の変数に読み込んだ後、すべてVBA内で一致をチェックし、出力配列を準備します。そうすれば、VBAとExcelの間に1つの相互作用、つまり出力シートをターゲットシートに書き込むことができます。一度に1つの行を削除するのは時間がかかりますので、「削除範囲」を1つだけ作成して、すべてを一度に実行する方がよいかもしれません。

これを達成するためのスケルトンコードを以下に示します（ただし、使用範囲が "A"で始まらず、UsedRangeより信頼性の高い関数を選択する場合は、「列オフセット」計算が必要です）。

TransferData "Silver", "Gold", "MCX" 

、ルーチン自体は次のようなものが好きかもしれません：あなたはそうのようなルーチンを呼び出し、あなたが完全に `LR`、` LR =シート（「データ」）への変更を修飾する必要が

Private Sub TransferData(ParamArray searchItems() As Variant) 
    Dim srcData As Variant 
    Dim txData() As Variant 
    Dim item As Variant 
    Dim r As Long, c As Long 
    Dim txIndexes As Collection 
    Dim delRng As Range 

    'Read source data into an array 
    'Note: I've used UsedRange as I don't know your sheet layout 
    srcData = ThisWorkbook.Worksheets("Data").UsedRange.Value2 

    'Check for matches and record index number 
    Set txIndexes = New Collection 
    For r = 1 To UBound(srcData, 1) 
     For Each item In searchItems 
      If srcData(r, 5) = item Then 
       txIndexes.Add r 
       Exit For 
      End If 
     Next 
    Next 

    'Trasfer data to output array 
    ReDim txData(1 To txIndexes.Count, 1 To UBound(srcData, 2)) 
    r = 1 
    For Each item In txIndexes 
     For c = 1 To UBound(srcData, 2) 
      txData(r, c) = srcData(item, c) 
     Next 
     r = r + 1 
    Next 

    'Write the transfer data to target sheet 
    With ThisWorkbook.Worksheets("Commodity") 
     .Cells(.Rows.Count, "A").End(xlUp).Resize(UBound(txData, 1), UBound(txData, 2)) = txData 
    End With 

    'Delete the transfered rows 
    For Each item In txIndexes 
     With ThisWorkbook.Worksheets("Data") 
      If delRng Is Nothing Then 
       Set delRng = .Cells(item, "A") 
      Else 
       Set delRng = Union(delRng, .Cells(item, "A")) 
      End If 
     End With 
    Next 
    If Not delRng Is Nothing Then delRng.EntireRow.Delete 

End Sub