Copy and Paste entire row if a specific cell agrees with if cond

Closed

PeriGr Posts 11 Registration date Monday July 17, 2017 Status Member Last seen August 12, 2017 - Aug 4, 2017 at 07:09 AM
PeriGr Posts 11 Registration date Monday July 17, 2017 Status Member Last seen August 12, 2017 - Aug 12, 2017 at 04:56 AM

Hello guys!

I have been writing a vba code for a while and I cant find the mistake that I am making... I have a big table and I am comparing the values between column U and V column U and W column AB with AC and finally AB with AD. So I am making 4 comparisons for each row. If the difference between any of these comparisons is bigger than a specific value I want to copy and paste the entire row to another sheet.. So, even if one comparison out of the 4 that exist in a row is not good (the difference is bigger), I want the whole row to pasted to the other sheet. .. can you please help??

Sub macro()

Dim mDiff1 As Double
mDiff1 = 0.01

Dim mDiff2 As Double
mDiff2 = 0.03

Dim mDiff3 As Double
mDiff3 = 0.01

Dim mDiff4 As Double
mDiff4 = 0.03

Sheets("TRACKER").Select

For Each cell1 In Range("U2:U" & Range("U" & Rows.Count).End(xlUp).Row)
If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Then
cell1.Offset(0, 1).Interior.ColorIndex = 3
End If
If cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then
cell1.Offset(0, 2).Interior.ColorIndex = 5
End If
If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Or cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then
cell1.EntireRow.Copy
Sheets("WFR+VFR report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If

Next cell1

For Each cell2 In Range("AB2:AB" & Range("AB" & Rows.Count).End(xlUp).Row)
If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Then
cell2.Offset(0, 1).Interior.ColorIndex = 3
End If
If cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then
cell2.Offset(0, 2).Interior.ColorIndex = 5
End If
If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Or cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then
cell2.EntireRow.Copy
Sheets("WFR+VFR report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If

Next cell2

End Sub

Copy and Paste entire row if a specific cell agrees with if cond
If cell contains text then return value multiple conditions ✓ - Excel Forum
This message was deleted text copy and paste - Android Forum
Excel conditional formatting if another cell contains specific text ✓ - Excel Forum
If cell contains date then return value ✓ - Office Software Forum
Saints row 2 cheats - Guide

3 responses

Answer 1 / 3

Blocked Profile
Aug 4, 2017 at 04:52 PM

The only way that this code will run, is by being called from a MACRO. Functions running USER DEFINED FUNCTIONS, cannot manipulate sheet data from a function (easily). It has to be performed by a macro. SO, if everything works but the copy and paste, it is because it is being calle dby a UDF, and not a macro. A simple work around, is attach a button, and run the same code from the button.

PeriGr Posts 11 Registration date Monday July 17, 2017 Status Member Last seen August 12, 2017
Aug 4, 2017 at 04:58 PM

First of all thank you very much for your answer! However, I didn't quite understand it :( I am running the above macro with a button (ctrl+a) and it is a macro.. So, what should I change to make it work? Do you see any glaring mistake? (also, I just want to copy and paste the values of the rows without the formulas).

Answer 2 / 3

Blocked Profile
Updated on Aug 4, 2017 at 06:54 PM

Well, I didn't see where Cell1 and cell2 were initialized as cells, or ranges, so I am not certain you are constructing the object correctly.

You might need to (edit)DECLARE

<del>initialize</del>

cell1 and cell2 as ranges, as in:

dim cell1 as RANGE

It's kind of fun to do the impossible! -Walter Elias Disney

Blocked Profile
Aug 4, 2017 at 05:03 PM

Also, try ROWS(1).SELECT

PeriGr Posts 11 Registration date Monday July 17, 2017 Status Member Last seen August 12, 2017
Aug 4, 2017 at 05:15 PM

Ok so I run the macro and it doesn't crush.. However, when I am done, it only copy and pastes the last row.. Other than that, it works fine with no crushes.. But I want all the rows.. So, the problem must be in the copy and paste section of the macro, since the coloring in the main sheet is done correctly too! The only part not working is copying and pasting all cells.. also, ROWS(1).SELECT where should I add it in the code?

Blocked Profile
Aug 4, 2017 at 06:35 PM

Well, you can handle the copy each row in Three ways (way more but these are the obvious ones, unless I miss one, then whatever...):

...Load each value you wish to copy, into an array, and then retrieve the array later;
or...
...Place the copy command in between each time it changes the color format;
or...
you could GOSUB the copy command, then RETURN.

Disregard the rows method if this is working for you.

If you need help with the GOSUB and RETURN syntax, give this a look over:
https://docs.microsoft.com/en-us/office/vba/Language/Reference/User-Interface-Help/gosubreturn-statement

PeriGr Posts 11 Registration date Monday July 17, 2017 Status Member Last seen August 12, 2017 > Blocked Profile
Aug 5, 2017 at 11:19 AM

Thanks again :) I tried everything.. nothing will work :( ouff ...This is my last format of code.. any last recommendations ?? Thank you very much for you time !

Sub WFRVFR_performance()

Dim mDiff1 As Double
mDiff1 = 0.01

Dim mDiff2 As Double
mDiff2 = 0.03

Dim mDiff3 As Double
mDiff3 = 0.01

Dim mDiff4 As Double
mDiff4 = 0.03

Dim cell1 As Range

Dim cell2 As Range

Sheets("TRACKER").Select

For Each cell1 In Range("U2:U" & Range("U" & Rows.Count).End(xlUp).Row)
      If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Then
        cell1.Offset(0, 1).Interior.ColorIndex = 3
      End If
      If cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then
        cell1.Offset(0, 2).Interior.ColorIndex = 5
      End If
      If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Or cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then GoSub CopyPastecell1
      Exit Sub
CopyPastecell1:
      cell1.EntireRow.Copy
      Sheets("WFR+VFR report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
      Return
      
      
Next cell1
      

For Each cell2 In Range("AB2:AB" & Range("AB" & Rows.Count).End(xlUp).Row)
      If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Then
        cell2.Offset(0, 1).Interior.ColorIndex = 3
      End If
      If cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then
        cell2.Offset(0, 2).Interior.ColorIndex = 5
      End If
      If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Or cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then GoSub CopyPastecell2
      Exit Sub
CopyPastecell2:
      cell2.EntireRow.Copy
      Sheets("WFR+VFR report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
      Return
           
Next cell2

End Sub

Blocked Profile
Aug 5, 2017 at 04:51 PM

YOu are only going to GOSUB if this condition is met:


If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Or cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then GoSub CopyPastecell1

Is that what you intnded?

Answer 3 / 3

Blocked Profile
Aug 11, 2017 at 04:40 PM

Sorry so slow in response...it is a terribly busy time for me, and I haven't been able to check back.

Post your entire code, so we can look at how it is flowing!

PeriGr Posts 11 Registration date Monday July 17, 2017 Status Member Last seen August 12, 2017
Updated on Aug 12, 2017 at 04:58 AM

ac3mark thank you very much for everything! you are doing me a huge favor so please dont even mention it :)

Sub WFRVFR_performance()

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Dim mDiff1 As Double
mDiff1 = 0.01

Dim mDiff2 As Double
mDiff2 = 0.03

Dim mDiff3 As Double
mDiff3 = 0.01

Dim mDiff4 As Double
mDiff4 = 0.03

Dim cell1 As Range

Dim cell2 As Range

Sheets("TRACKER").Select
    
For Each cell1 In Range("U2:U" & Range("U" & Rows.Count).End(xlUp).Row)
      If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Then
      cell1.Offset(0, 1).Interior.ColorIndex = 3
      End If
      If cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then
      cell1.Offset(0, 2).Interior.ColorIndex = 5
      End If
      If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Or cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then GoSub CopyPastecell1
      Exit Sub
CopyPastecell1:
      cell1.EntireRow.Copy
      Sheets("WFR+VFR report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
      Return
      
Next cell1
      
For Each cell2 In Range("AB2:AB" & Range("AB" & Rows.Count).End(xlUp).Row)
      If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Then
      cell2.Offset(0, 1).Interior.ColorIndex = 3
      End If
      If cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then
      cell2.Offset(0, 2).Interior.ColorIndex = 5
      End If
      If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Or cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then GoSub CopyPastecell2
      Exit Sub
CopyPastecell2:
      cell2.EntireRow.Copy
      Sheets("WFR+VFR report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
      Return
  
Next cell2

Sheets("WFR+VFR report").Select

Columns(4).RemoveDuplicates Columns:=Array(1)
On Error Resume Next
Columns(4).SpecialCells(xlBlanks).EntireRow.Delete

For Each cell1 In Range("U2:U" & Range("U" & Rows.Count).End(xlUp).Row)
      If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Then
        cell1.Offset(0, 1).Interior.ColorIndex = 3
      End If
      If cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then
        cell1.Offset(0, 2).Interior.ColorIndex = 5
      End If

Next cell1

For Each cell2 In Range("AB2:AB" & Range("AB" & Rows.Count).End(xlUp).Row)
      If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Then
        cell2.Offset(0, 1).Interior.ColorIndex = 3
      End If
      If cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then
        cell2.Offset(0, 2).Interior.ColorIndex = 5
      End If

Next cell2

Sheets("TRACKER").Select

Sheets("TRACKER").Range("A1:AU1").Copy Sheets("WFR+VFR report").Range("A1:AU1")

Sheets("WFR+VFR report").Select
If Not ActiveSheet.AutoFilterMode Then
ActiveSheet.Rows(1).AutoFilter
End If

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

Similar discussions

How to use conditional format based on text?

Highlight cell if another cell contains specific text

If a cell contains any text then add a value

Counting cells containing only numbers

Can no longer paste text into insta

Similar discussions

Subscribe To Our Newsletter!