Copy 3rd Cell from under Same Row Where Col B is not empty

Question

I have been trying to create a function which checks that if Col"B" <> Empty then copy the third cell which is under the same row.

I have this Data:

Where from i want to copy the Col"D" highlighted cells and paste them into same row where Col"B" <> empty.

Here is the final result. Your help will be appreciated in this regards.

Option Explicit
Sub CopyPasting()
    
Dim ws As Worksheet
Dim r As Long
Dim LastRow As Long
Dim n As Long
        
        Set ws = ThisWorkbook.Sheets("Sheet1")
        With ws
            LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
            
        For r = LastRow To 2 Step -2
                If .Cells(r, "B") <> "" Then
                .Rows(r + "D").Copy
                .Rows(r + "D").PasteSpecial
    
            n = n + 1
            End If
            Next
    End With
    End Sub

Answer 1

Please, try the next code:

Sub testRetOffset3()
  Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, c As Range
  Set sh = ActiveSheet  'use here the sheet you need
  lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last sheet row
  On Error Resume Next  'if not empty cells in column, it will not return the range and raise an error
  Set rngV = sh.Range("B2:B" & lastR).SpecialCells(xlCellTypeConstants)
  On Error GoTo 0
  If rngV Is Nothing Then Exit Sub  'stop the code if run on a wrong sheet, without empty cells in column B:B
  For Each c In rngV.cells          'iterate between the discontinuous range cells
    If rngFin Is Nothing Then       'if the final range is not set (first time)
        Set rngFin = c.Offset(3, 2) 'set the range = the Offset necessary cell
    Else
        Set rngFin = Union(rngFin, c.Offset(3, 2)) 'make a Union between existing range and the Offset necessary cell
    End If
  Next
  If Not rngFin Is Nothing Then  'copy both ranges in consecutive columns
        rngV.Copy sh.Range("F2")  
        rngFin.Copy sh.Range("G2")
  End If
End Sub

It will return in columns F:G, starting from the second row. It is easy to modify the range where to return...

You can even clear the existing processed columns and return in B:C, or in another sheet.

Edited: In order to solve the last request, please use the next code:

Sub testRetOffsetMoreRows()
  Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, A As Range
  Set sh = ActiveSheet
  lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
  On Error Resume Next
  Set rngV = sh.Range("A2:D" & lastR).SpecialCells(xlCellTypeConstants)
  On Error GoTo 0
  If rngV Is Nothing Then Exit Sub
  For Each A In rngV.Areas  'iterate between the range areas
    If rngFin Is Nothing Then
        Set rngFin = A.cells(1,2).Offset(3, 3) 'use the second cell of the area
    Else
        Set rngFin = Union(rngFin, A.cells(1,2).Offset(3, 3))
    End If
  Next
  If Not rngFin Is Nothing Then
        rngV.Copy sh.Range("H2")
        rngFin.Copy sh.Range("L2")
  End If
End Sub

But take care to have continuous ranges when have a value in column B:B. Otherwise, the code may fail... The areas property will return differently.