Copier/Coller cellules selon ce qu'elles contiennent

Bonjour,

J'ai passé des heures entières à fouiller les forum pour trouver une solution mais je début en VBA et je n'arrive pas à adapter les conseils que j'ai lu à ma situation.

Pourriez-vous m'aider à résoudre mon problème ?

Il s'agit de copier/coller des cellules spécifiques issues de la colonne A (cellules qui contiennent le mot "CONSULTER" uniquement) dans la colonne D.

Informations + :

Ces cellules ne sont pas situées à des intervalles réguliers.

Ces cellules renvoient vers des pages internet.

Note +:

J'ai tenté d'enregistrer la macro mais lorsque je la lance, elle bute sur "Selection.fillright" (cf. vers le milieu du code ci-dessous) :

Merci pour celles et ceux qui se pencheront sur mon problème.

Vincent

Code VBA :

Option Explicit

Sub Copier_CONSULTER()

'

' Copier_CONSULTER Macro

'

'

ActiveSheet.Range("$A$1:$D$2000").AutoFilter Field:=1, Criteria1:= _

"CONSULTER"

Columns("B:C").Select

Selection.EntireColumn.Hidden = True

Range("A12").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Selection.FillRight ActiveWindow.ScrollRow = 2000

ActiveWindow.ScrollRow = 1

Cells.Select

Selection.EntireColumn.Hidden = False

ActiveSheet.Range("$A$1:$D$2000").AutoFilter Field:=1

End Sub

Bonjour et

S'il s'agit de recopier, en colonne D le lien figurant en colonne A, essaie ce qui suit:

Sub Copier_CONSULTER()

Dim derlig As Long, lig As Long

With Sheets("Feuil4")
    derlig = .Cells(Rows.Count, 1).End(xlUp).Row
    For lig = 2 To derlig
        If .Cells(lig, 1) = "CONSULTER" Then .Cells(lig, 1).Copy .Cells(lig, 4)
    Next lig
End With
End Sub

Merci beaucoup pour ta réponse.

J'avais trouvé une solution alternative mais bien moins clean que la tienne

C'est top.

Juste pour info, voici l'alternative que j'avais trouvée :

Sub Macro_CONSULTER_brouillon()
Application.ScreenUpdating = False
    ActiveSheet.Range("$A$1:$D$2000").AutoFilter Field:=1, Criteria1:= _
        "CONSULTER"

    For Each cell In Sheets(1).Range("A2:A" & Sheets(1).Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
    If cell.Value <> "" Then
            cell.Offset(0, 3).Value = cell.Value
        End If
    Next cell
        ActiveSheet.Range("$A$1:$G$2000").AutoFilter Field:=1
Application.ScreenUpdating = True 'Facultatif
End Sub

Pas vraiment jojo ^^