Looping until blank

[Jas]

Hi,

I have values in Col Q and if that is set to "yes" and Col R is blanks, then
I need the macro to copy the value in Col B (all on the same row) and paste
on to another spreadsheet. I also need the macro to put the date in Col R. It
needs to loop through this until it hits a blank cell.

Can anyone help?

Thanks
Jas

 

[Per Jessen]

Hi

Try this:

Sub aaa()
Dim TargetRange As Range
Dim CopyToWb As Workbook
Dim CopyToSh As Worksheet
Dim CopyToCell As Range
Dim Cell As Range

Set CopyToWb = Workbooks("Book2.xls") ' Change to suit
Set CopyToSh = CopyToWb.Worksheets("Sheet1") ' change sheet name to suit
Set CopyToCell = CopyToSh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
' Copy to FIrst empty cell in column A

TargetCol = "Q"
FirstRow = 2 ' Headings in row 1
LastRow = Cells(FirstRow, TargetCol).End(xlDown).Row
Set TargetRange = Range(TargetCol & FirstRow, TargetCol & LastRow)

For Each Cell In TargetRange
If Cell.Value = "yes" And IsEmpty(Cell.Offset(0, 1).Value) Then
Cell.Offset(0, -15).Copy Destination:=CopyToCell
Set CopyToCell = CopyToCell.Offset(1, 0)
Cell.Offset(0, 1) = Date
End If
Next
End Sub


Regards,
Per

 

[Jas]

Hi Per Jessen,

That worked perfectly. Thank you very much for all your help.

Jas