Parcours de colonne et copier/coller

Bonjour,

Je souhaite réaliser une macro qui parcours toutes les colonnes dans la range [A7 : CM7].

Si la valeur de la cellule "x"7 est égale à SJS, je copie la colonne entière et je la colle dans ma nouvelle feuille, sinon, je passe à la suivante.

Voici ce que j'ai déjà écrit :

Sub Extract()
Dim Col As Range, C As Range
Dim j As Integer
j = 0
    For Each Col In Range("A7:CM7").Columns 'pour chaque colonne entre A7 et CM7
        For Each C In Col.Cells 'on parcours les cellules
            If (C.Value = "SJS") Then
                Columns(Col).Select
                Selection.Copy
                Sheets("Application referential").Select
                Range(j, 1).Select
                ActiveSheet.Paste
                j = j + 1
            End If
        Next
    Next
End Sub

J'ai une erreur "imcompatibilité de type" au niveau de l'instruction Columns(Col).Select

Comment pourrais-je résoudre cette erreur?

Merci à vous !

Hello Rosees.

Essaye avec ce code pour voir si celà te conviens.

Sub Extract()

Dim Col As Range, C As Range

Dim j As Integer

j = 1

For Each Col In Range("A7:CM7").Columns 'pour chaque colonne entre A7 et CM7

For Each C In Col.Cells 'on parcours les cellules

If (C.Value = "SJS") Then

Col.Select

Selection.Copy

Sheets("Application referential").Select

Cells(j, 1).Select

ActiveSheet.Paste

j = j + 1

End If

Next

Next

End Sub

Cdlt.

Bonjour,

une autre approche :

Option Explicit
Sub Extract()
Dim C As Range
For Each C In Range("A7:CM7")
    If C.Value = "SJS" Then
        With Sheets("Application referential")
            Columns(C.Column).Copy Destination:=.Columns(.Range("IV1").End(xlToLeft).Offset(0, 1).Column)
        End With
    End If
Next C
End Sub

bonne journée

@+

Oui c'est sur ton code Pierrot est beaucoup plus "net" clap clap.

Bonjour,

Si j'ai bien compris

Cdlt.

Option Explicit
Public Sub Extract()
Dim wss As Worksheet, wsd As Worksheet
Dim derCol As Integer, i As Integer, Col As Integer
Dim c As Range

    Application.ScreenUpdating = False

    Set wss = Worksheets("Feuil1")
    Set wsd = Worksheets("Feuil2")

    With wsd
        .Cells.Clear
    End With

    Col = 1

    With wss
        derCol = .Cells(7, Columns.Count).End(xlToLeft).Column
        For i = 1 To derCol
            If .Cells(7, i) = "SJS" Then
                Columns(i).Copy Destination:=wsd.Columns(Col)
                Col = Col + 1
            End If
        Next
    End With

    Set wss = Nothing: Set wsd = Nothing

End Sub

Merci à vous tous, quelle rapidité !

Jean-Eric, comment l'instruction suivante arrive à déterminer la dernière colonne du fichier ?

derCol = .Cells(7, Columns.Count).End(xlToLeft).Column

A te relire.