CODEWITHSUNDEEP
vbaexcelloops
Red
Red

Reputation: 5

Looping a cut and paste if criteria is met

I am trying to loop the following 

Dim x As Integer
Dim y As Integer

x = Range("AE4")
y = Range("AD4")

If x >= y Then
Range("AE4").Select
Selection.Copy
Range("AD4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Else

End If

Once this cell AE4 has been checked and then copied or not depeding of it is greater or = to AD4 i would like this to then move on to AE5, AE6 etc to the end of the data set. any ideas what i need to do next? I currently have the rest of the script executed before this checking iof the a cell date is below 4 weeks and then 5 weeks, 6 weeks old up to 10 weeks. and is currenlty working as expected checking the date of the cell and then checking and copying the first cell in the data.

Full script is as follows.

Sub Test()

  Range("AE4").Select
    ActiveCell.Formula = _
      "=IF(RC[-2]>=TODAY()-28,""1"",IF(AND(RC[-2]<TODAY()-28,RC[-2]>=TODAY()-35),""4"",IF(AND(RC[-2]<TODAY()-35,RC[-2]>=TODAY()-42),""5"",IF(AND(RC[-2]<TODAY()-42,RC[-2]>=TODAY()-49),""6"",IF(AND(RC[-2]<TODAY()-49,RC[-2]>=TODAY()-56),""7"",IF(AND(RC[-2]<TODAY()-56,RC[-2]>=TODAY()-63),""8"",IF(AND(RC[-2]<TODAY()-63,RC[-2]>=TODAY()-70),""9"",IF(RC[-2]<TODAY()-70,""10""))))))))"
  Range("AE4").Select
  Selection.AutoFill Destination:=Range("AE4:AE200")
  Range("AE4:AE200").Select

  Dim x As Integer
  Dim y As Integer

  x = Range("AE4")
  y = Range("AD4")

  If x >= y Then
  Range("AE4").Select
  Selection.Copy
  Range("AD4").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

  Else

  End If
End Sub

Upvotes: 0

Views: 756

Answers (2)

Ambie
Ambie

Reputation: 4977

Below is some code that'll do what I think you're asking. It looks as though you're relying on the macro generator quite heavily which tends to 'select' a lot more than a developer needs to do. Have a play with your code and look at other posts to see how others do it.

Sub Test()
    Dim ws As Worksheet
    Dim startCell as Range
    Dim fullRng As Range
    Dim thisCell As Range
    Dim leftCell as Range

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set startCell = ws.Range("AE4")
    Set fullRng = startCell.Resize(196)

    startCell.Formula = "=IF(RC[-2]>=TODAY()-28,""1"",IF(AND(RC[-2]<TODAY()-28,RC[-2]>=TODAY()-35),""4"",IF(AND(RC[-2]<TODAY()-35,RC[-2]>=TODAY()-42),""5"",IF(AND(RC[-2]<TODAY()-42,RC[-2]>=TODAY()-49),""6"",IF(AND(RC[-2]<TODAY()-49,RC[-2]>=TODAY()-56),""7"",IF(AND(RC[-2]<TODAY()-56,RC[-2]>=TODAY()-63),""8"",IF(AND(RC[-2]<TODAY()-63,RC[-2]>=TODAY()-70),""9"",IF(RC[-2]<TODAY()-70,""10""))))))))"
    startCell.AutoFill fullRng

    For Each thisCell In fullRng.Cells
        Set leftCell = thisCell.Offset(, -1)
        Debug.Print("Before If: " & thisCell.Address(False, False) & "=" & thisCell.Value2 & " v. " & leftCell.Address(False, False) & "=" & leftCell.Value2)
        If thisCell.Value2 >= leftCell.Value2 Then
            leftCell.Value2 = cell.Value2
            Debug.Print("After If: " & thisCell.Address(False, False) & "=" & thisCell.Value2 & " v. " & leftCell.Address(False, False) & "=" & leftCell.Value2)
        End If
    Next

End Sub

Upvotes: 2

Vaizard27
Vaizard27

Reputation: 48

Easiest way is probably a lopp that just repeats what you are doing. Instead of defining x and y as ranges, you would only need a count variable:

dim lastrow as integer
lastrow = Cells(Rows.count, "AE").End(xlUp).row 'counts the amount of cells you have with values in the row

for i = 2 to lastrow 'set 2 = whatever, but I guess you have header rows, if you want to start in the 4th row set it 4

if CELLS(i,31).Value >= CELLS(i,30).Value THEN 'the cell commands uses 1-indexed numbers to refer to cells on an x-y axis, rows go on the x axis so Cells(2,1) is "B1" for some reason.
    'insert your loop here
    Cells(i,31).Select
    Selection.Copy
    Cells(i,30).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
End if
Next i

Upvotes: 0

Related Questions