1
votes

i am having real difficulty finding anything that has my query. I can find the different pieces of what i need but cannot put it together.

What i need to do is look through a set range and if value is between 0.001 and 0.26 then copy cell and paste in next empty cell in column ("DA"), also copy cell from the same row that the value was found but copy from column ("C") and paste in next to column ("DB").

I know i have to loop through with an If statement, and i will have to offset cell when it finds match to criteria. but i cannot put it together.

I have tried the following pieces of code.

Sub COPYcell()
Dim Last As Long
Dim i As Long, unionRng As Range

Last = 61
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("DA100").End(xlUp).Row

    For i = 5 To Last
        If (.Cells(i, "J").Value) >= 0.01 And (.Cells(i, "J").Value) <= 0.26 Then

           'Cells(i, "DA").Value = Cells(i, "J").Value
           Range(i, "J").Copy = Range("DA" & lastrow)
           Cells(i, "J").Offset(, -8) = Range("DB" & lastrow)
           Range("DC" & lastrow) = "July"

         End If
         Next i                          

End Sub

3
would you not mean <=0.26?Jeremy Kahan
Also within that if I think you would need to say lastrow=lastrow+1 or else you will keep overwriting yourself.Jeremy Kahan
Thanks for replying Jeremy Kahan, i'm not sure what you mean by the +1. My current code doesn't work, not sure why. are you able to help?AdmirE

3 Answers

0
votes

Your current code was giving me errors about range objects. I kept it simple and assigned cell values to cell values. Also, I am not sure if you meant .01 or .001. You may fiddle with that. The issue I saw was that as you find more matches, you want lastrow to go up so you are writing in what is now the last row, not what once was. You also had some unused variables pasted in, so I simplified. Here is the result.

    Sub COPYCell()
Dim Last As Long
Dim i As Long

Last = 61
Dim lastrow As Long

lastrow = Sheets("Sheet1").Range("DA100").End(xlUp).Row + 1

For i = 5 To Last
    If (Cells(i, "J").Value <= 0.26) And (Cells(i, "J").Value >= 0.001) Then

           Cells(lastrow, "DA").Value = Cells(i, "J").Value
           Cells(lastrow, "DB").Value = Cells(i, "C").Value
           Cells(lastrow, "DC").Value = "July"
           lastrow = lastrow + 1
         End If
         Next i
End Sub

EDIT Added +1 on lastRow per comment. I had tested where I had none yet.

1
votes

Try the following:

Option Explicit    
Public Sub COPYcell()
    Dim last As Long, sht1 As Worksheet
    Dim i As Long, unionRng As Range, lastrow As Long, nextRow
    Application.ScreenUpdating = False
    Set sht1 = Worksheets("Sheet1")
    last = 61

    With sht1
        lastrow = .Cells(.Rows.Count, "DA").End(xlUp).Row
        nextRow = IIf(lastrow = 1, 1, lastrow + 1)
        For i = 5 To last
            If .Cells(i, "J").Value >= 0.01 And .Cells(i, "J").Value <= 0.26 Then '1%=26%
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(unionRng, .Cells(i, "J"))
                Else
                    Set unionRng = .Cells(i, "J")
                End If
            End If
        Next i

        If Not unionRng Is Nothing Then
            unionRng.Copy .Range("DA" & nextRow)
            unionRng.Offset(0, -7).Copy .Range("DB" & nextRow)
        End If
    End With
    Application.ScreenUpdating = False
End Sub
0
votes

You need to loop your range and inside loop check if you cell is not empty copy the cell value and in else paste in next empty cell.

Sample code:

Sub Func ()
Dim rng As Range, cell As Range
Set rng = Range("A1:A3")
For Each cell In rng
  If (IsEmpty(cell.value))
    Cell.paste()
  Else 
    cell.copy()
  End if
Next cell
End sub

The code is not tested because I typed it on a phone.