CODEWITHSUNDEEP
vbaexcel
VBA Pete
VBA Pete

Reputation: 2666

Storing multiple values in variant and delete rows at the end of sub

I have written the following code which is supposed to run through a data set and delete all rows that do not match the value in call C1. In my original code I deleted line by line and the code was very slow, so now I am trying to add all values to a variant and delete all cells at the end. Is this possible?

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

Right now the code only deletes the last row as the variant is overwritten each time as it runs through the loop. Any suggestions on how I can store all values in the variant and delete the rows I don't need at the end?

Thanks for you help!

Upvotes: 0

Views: 189

Answers (2)

user6432984
user6432984

Reputation:

The fastest way is to

  • Load the data into an array
  • Copy the valid data into a second array
  • Clear the contents of the range
  • Write the second array back to the worksheet
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

Upvotes: 1

Dirk Reichel
Dirk Reichel

Reputation: 7979

As you need a range holding all rows, you can collect it in one "on the run" like this:

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

Upvotes: 1

Related Questions