CODEWITHSUNDEEP
vbaexcel
AdmirE
AdmirE

Reputation: 35

Loop through range and if cell contains value copy to next empty cell in column

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 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

Upvotes: 1

Views: 2694

Answers (3)

Abhishek Tomar
Abhishek Tomar

Reputation: 905

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.

Upvotes: 0

Jeremy Kahan
Jeremy Kahan

Reputation: 3826

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.

Upvotes: 0

QHarr
QHarr

Reputation: 84465

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

Upvotes: 1

Related Questions