バリアントに複数の値を格納し、サブの末尾にある行を削除します

Question

データセットを実行し、呼び出しC1の値と一致しないすべての行を削除するはずの次のコードを記述しました。私の元のコードでは、行ごとに削除され、コードは非常に遅かったので、今はすべての値をバリアントに追加し、最後にすべてのセルを削除しようとしています。これは可能ですか？

Sub FixData() 

Dim wbFeeReport As Workbook 
Dim wsData As Worksheet 
Dim wsData2 As Worksheet 
Dim FrRngCount As Range 
Dim x As Long 
Dim y As Long 
Dim varRows As Variant 

Set wbFeeReport = ThisWorkbook 
Set wsData = wbFeeReport.Worksheets("Data") 
Set wsData2 = wbFeeReport.Worksheets("Data2") 

Set FrRngCount = wsData.Range("D:D") 
y = Application.WorksheetFunction.CountA(FrRngCount) 

For x = y To 2 Step -1 
If wsData.Range("J" & x).Value <> wsData2.Range("C1").Value Then 
varRows = x 
Else 
wsData.Range("AF" & x).Value = wsData.Range("J" & x).Value 
End If 
Next x 

wsData.Rows(varRows).EntireRow.Delete 

End Sub 

コードはループを通過するたびにバリアントが上書きされるので、コードは最後の行のみを削除します。バリアント内のすべての値をどのように保存し、最後に不要な行を削除するかについてのご提案ですか？

ありがとうございました！

Answer 1

最速の方法は

• にあるデータをロード配列
• コピー二番目の配列
• クリアに有効なデータは、範囲の内容
• は、第二ARRを書きますAYバックワークシート

---

Sub FixData() 
    Dim Source As Range 
    Dim Data, Data1, TargetValue 
    Dim x As Long, x1 As Long, y As Long 

    Set Source = Worksheets("Data").Range("A1").CurrentRegion 
    TargetValue = Worksheets("Data2").Range("C1") 

    Data = Source.Value 
    ReDim Data1(1 To UBound(Data, 1), 1 To UBound(Data, 2)) 

    For x = 1 To UBound(Data, 1) 
     If x = 1 Or Data(x, 10) = TargetValue Then 
      x1 = x1 + 1 
      For y = 1 To UBound(Data, 2) 
       Data1(x1, y) = Data(x, y) 
      Next 
     End If 
    Next 

    Source.ClearContents 
    Source.Resize(x1).Value = Data1 

End Sub 

Answer 2

あなたはすべての行を保持する範囲を必要とするとして、あなたはこのような「実行時に」1で、それを収集することができます。

Sub FixData() 

    Dim wsData As Worksheet 
    wsData = ThisWorkbook.Worksheets("Data") 

    Dim val As Variant 
    val = ThisWorkbook.Worksheets("Data2").Range("C1").Value 

    Dim DelRows As Range, x As Long 

    For x = 2 To wsData.Cells(wsData.Rows.Count, 4).End(xlUp).Row 
    If wsData.Range("J" & x).Value <> val Then 
     If DelRows Is Nothing Then 
     Set DelRows = wsData.Rows(x) 
     Else 
     Set DelRows = Union(wsData.Rows(x), DelRows) 
     End If 
    Else 
     wsData.Range("AF" & x).Value = wsData.Range("J" & x).Value 
    End If 
    Next x 

    DelRows.EntireRow.Delete 

End Sub