In base a quanto scritto nel 1° post

Sub Copia()
Dim Ur As Long, X As Long
Ur = Range("B" & Rows.Count).End(xlUp).Row
    For X = 4 To Ur
        If Cells(X, 14) = Date Then
            Cells(X, 17) = Cells(X, 2)
            Cells(X, 18) = Cells(X, 12)
        End If
    Next X
End Sub

Frasubb ha scritto:

a partire da Q13 per i nominativi e R13

Adesso incomincia ad avere più senso   

La macro di raffaele53 l'hai provata/adattata?

Magari per il tuo scopo la modificherei così:

Sub Copia()
    Dim Ur As Long, X As Long, j As Long

    Ur = Range("B" & Rows.Count).End(xlUp).Row
    j = 13
    For X = 4 To Ur
        If Cells(X, 14) = Date Then
            Cells(j, 17) = Cells(X, 2)
            Cells(j, 18) = Cells(X, 12)
            j = j + 1
        End If
    Next X
End Sub

N.B. Fai attenzione che molte celle in colonna "R" hanno il colore del carattere nero e perciò si sovrasta con il nero della cella, a quel punto non vedi ciò che è scritto.

ciao

togliendo le celle unite, sub che ottiene entrambi gli elenchi

Sub CopiaDati()
Dim r As Integer, r1 As Integer, r2 As Integer
Range("Q3:U1000").Clear
r1 = 3: r2 = 3
For r = 3 To Range("B" & Rows.Count).End(xlUp).Row
   If Cells(r, "N") = Date Then
      Cells(r1, "Q") = Cells(r, "B"): Cells(r1, "R") = Cells(r, "L")
      r1 = r1 + 1
   ElseIf Cells(r, "N") < Date Then
      Cells(r2, "T") = Cells(r, "B"): Cells(r2, "U") = Cells(r, "L")
      r2 = r2 + 1
    
   End If
Next r
End Sub

ciao,

mi risulta tutto corretto