VBA: Copy rows with Changes

[gerald24]

Hi Guys,

Need help with the below.

So I need to copy the whole row of those crops that have changes in length from day 1 to day 2.

The below is just an example, true data contains many rows and columns. I don't want to add another column that will check if day 1 and day 2 are the same.

What I want to achieve is a macro that will compare (and copy to another sheet) per Row, columns Day 1 Length and Day 2 Length if there are any changes. Can somebody help me with the codes please?

Technically, I want the macro to copy Banana Row and Carrots Row to another sheet without the use of additional Column that will check if Day 1 and Day 2 are the same.

[table="width: 500"]
[tr]
[td]Crop
[/td]
[td]Day 1 Length
[/td]
[td]Day 2 Length
[/td]
[td]Fertilizer
[/td]
[/tr]
[tr]
[td]Apple
[/td]
[td]1.5[/td]
[td]1.5[/td]
[td]A[/td]
[/tr]
[tr]
[td]Banana[/td]
[td]2.6[/td]
[td]2.7[/td]
[td]B[/td]
[/tr]
[tr]
[td]Carrots[/td]
[td]1.8[/td]
[td]2.1[/td]
[td]C[/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[/table]


Many Thanks!!!

 

[Fluff]

How about

Sub CheckLength()

   Dim Cl As Range
   Dim Rng As Range
   
   For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
      If Not Cl.Value = Cl.Offset(, 1).Value Then
         If Rng Is Nothing Then
            Set Rng = Cl
         Else
            Set Rng = Union(Rng, Cl)
         End If
      End If
   Next Cl
   If Not Rng Is Nothing Then Rng.EntireRow.Copy Sheets("Data").Range("A2")
End Sub

 

[gerald24]

Hi Fluffy,

Works like magic, my 3k+ lines done within 5 seconds.
Could you please explain to me the logic? So that next time I'll try it on my own.

THANK YOU SO MUCH!!!!

How about

Sub CheckLength()

   Dim Cl As Range
   Dim Rng As Range
   
   For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
      If Not Cl.Value = Cl.Offset(, 1).Value Then
         If Rng Is Nothing Then
            Set Rng = Cl
         Else
            Set Rng = Union(Rng, Cl)
         End If
      End If
   Next Cl
   If Not Rng Is Nothing Then Rng.EntireRow.Copy Sheets("Data").Range("A2")
End Sub

 

[Fluff]

Sub CheckLength()

         Dim Cl As Range
         Dim Rng As Range
         
1        For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
2           If Not Cl.Value = Cl.Offset(, 1).Value Then
3              If Rng Is Nothing Then
4                 Set Rng = Cl
5              Else
6                 Set Rng = Union(Rng, Cl)
7              End If
8           End If
9        Next Cl
10       If Not Rng Is Nothing Then Rng.EntireRow.Copy Sheets("Data").Range("A2")
End Sub

1) Loops through col B from B2 downwards
2) Checks if the value in col B = the value in col C, if it does then moves to line 8, otherwise moves to line 3
3) Checks if Rng already has a value, if it does moves to line 5 otherwise line 4
4) sets Rng to the current cell of col B
5) Sets Rng to the existing range & the current cell in col B
10) If Rng has a value then copy the entire row(s) to a new sheet

HTH