copier des cellules remplis

=SI(B3="";"";SI(NB.SI(Feuil2!A:A;B3);RECHERCHEV(B3;Feuil2!A:B;2;0);SI(NB.SI(Feuil3!B:B;B3);RECHERCHEV(B3;Feuil3!B:C;2;0);"")))

Option Explicit
Option Compare Text 'la casse n'a pas d'importance

Sub Synthese()
Dim w As Worksheet, cel As Range, tablo$(), n&
For Each w In Worksheets
  If w.Name Like "audit*" Then
    For Each cel In w.[D:D].SpecialCells(xlCellTypeConstants)
      If Not cel Like "nature de non*" Then
        ReDim Preserve tablo(1, n)
        tablo(0, n) = cel.Offset(, -2)
        tablo(1, n) = cel
        n = n + 1
      End If
    Next
  End If
Next
Sheets("CONSULTATION").[C80:D10000].ClearContents
If n Then Sheets("CONSULTATION").[C80].Resize(n, 2) = Application.Transpose(tablo)
End Sub

Option Explicit
Option Compare Text 'la casse n'a pas d'importance

Private Sub Worksheet_Activate()
Dim w As Worksheet, cel As Range, tablo$(), n&
For Each w In Worksheets
  If w.Name Like "audit*" Then
    For Each cel In w.[D:D].SpecialCells(xlCellTypeConstants)
      If Not cel Like "nature de non*" Then
        ReDim Preserve tablo(1, n)
        tablo(0, n) = cel.Offset(, -2)
        tablo(1, n) = cel
        n = n + 1
      End If
    Next
  End If
Next
[C80:D10000].ClearContents
If n Then [C80].Resize(n, 2) = Application.Transpose(tablo)
End Sub

Application.ScreenUpdating = False
[C80:D10000].Delete xlUp
If n = 0 Then Exit Sub
With [C80].Resize(n, 2)
  .Value = Application.Transpose(tablo)
  .Font.Size = 20 'taille police
  .Borders.LineStyle = 1 'bordures
End With
End Sub

Range([C80].Offset(n), Cells(Rows.Count, "D")).Delete xlUp
If n = 0 Then Exit Sub
With [C80].Resize(n, 2)
  .Font.Size = 20 'taille police
  .Borders.LineStyle = 1 'bordures
  .Value = Application.Transpose(tablo)
End With