Sélection seulement plage contenant cellule en question; pas toute la ligne

Bonjour tout le monde

Je m'adresse à vous pour m'aider à résoudre un problème de copier une plage de cellules de même rangée (et pas la copie

de toute la ligne qui emporte

tout ce qui se trouve à droite du tableau avec) selon critère des cellules de la colonne "N" qui contiennent le mot "Apte" ; ceci depuis la feuille "Base" vers la feuille "ArchivBase". les feuilles ont les mêmes formes.

Sub kopier()
 ''' Depuis feuille"Base" vers Feuille "ArchivBase";copier seulement les cellules de même ligne
 ''' à partir de la colonne A jusqu'à la cellule qui contient "Apte"(colonne N)
 ''' mais pas toute la ligne "Entirerow"

Dim i As Integer
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Base")
          For Each C In .Range("N5:N" & .Range("N" & Rows.Count).End(xlUp).Row)
             If C = "Apte" Then
                C.EntireRow.Copy

             'selection de la la cllule colonne A non vide juste après le tableau de reception
             Sheets("ArchivBase").Range("A" & i).Select
             Selection.PasteSpecial Paste:=xlValues

            Application.CutCopyMode = False
           End If
    Next C

End With
End Sub

La macro ci-jointe, tantôt fonctionne et copie une ligne en question mais pas toutes à la fois et tantôt se coince.

Les données dans Base sont fictives.

Merci pour votre aide et bonne journée.

Bonjour

Un essai à tester. Te convient-il ?

Bye !

 Option Explicit
Sub kopier()
  ''' Depuis feuille"Base" vers Feuille "ArchivBase";copier seulement les cellules de même ligne
  ''' à partir de la colonne A jusqu'à la cellule qui contient "Apte"(colonne N)
  ''' mais pas toute la ligne "Entirerow"

    Dim i As Integer
    Dim derLn&, lgn&

    derLn = Sheets("Base").Range("A" & Rows.Count).End(xlUp).Row
    With Sheets("Base")
        For i = 5 To derLn
            If Sheets("Base").Range("N" & i) = "Apte" Then
                lgn = Sheets("ArchivBase").Range("A" & Rows.Count).End(xlUp).Row + 1
                Sheets("Base").Range("A" & i & ":N" & i).Copy
                Sheets("ArchivBase").Range("A" & lgn).PasteSpecial xlPasteAll

                 'selection de la la cllule colonne A non vide juste après le tableau de reception
                 'Sheets("ArchivBase").Range("A" & i).Select
                 'Selection.PasteSpecial Paste:=xlValues
                Application.CutCopyMode = False
            End If
        Next i

    End With
    Sheets("ArchivBase").Activate
End Sub

Bonjour tout le monde. Une proposition de plus. Attention aux espaces blancs autour du mot "Apte", ce n'est pas très solide et ça trompe énormément .

Sub kopier()
    Dim nl1 As Integer, nl2 As Integer
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Sheets("BASE")
    Set ws2 = Sheets("ArchivBase")

    nl1 = ws1.Cells(Columns.Count, 2).End(xlUp).Row

    For i = 5 To nl1
        nl2 = ws2.Cells(Columns.Count, 2).End(xlUp).Row + 1
        If Trim(ws1.Cells(i, 14)) = "Apte" Then
            ws1.Range("A" & i & ":N" & i).Copy
            ws2.Range("A" & nl2).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
End Sub

Bonjour à toutes et tous,

Et une de plus avec POWER QUERY, pour actualiser .

Cdlt

Bonsoir tout le monde

Je remercie les membres: GMB, Optimix et mdo100 qui ont répondu à ce sujet.

Cdlt