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

Closed
Report
Posts
11
Registration date
Monday July 17, 2017
Status
Member
Last seen
August 12, 2017
-
Posts
11
Registration date
Monday July 17, 2017
Status
Member
Last seen
August 12, 2017
-
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

3 replies


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.
0
Posts
11
Registration date
Monday July 17, 2017
Status
Member
Last seen
August 12, 2017

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).
0
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
0
Blocked Profile
Also, try ROWS(1).SELECT
0
Posts
11
Registration date
Monday July 17, 2017
Status
Member
Last seen
August 12, 2017

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?
0
Blocked Profile
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
0
Posts
11
Registration date
Monday July 17, 2017
Status
Member
Last seen
August 12, 2017
> Blocked Profile
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
0
Blocked Profile
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?
0

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!
0
Posts
11
Registration date
Monday July 17, 2017
Status
Member
Last seen
August 12, 2017

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

0