XL 2013 Macro / Copier sans suppression

[Mathieu_dup]

Bonjour à tous,

Ayant fait du VBA il y a quelques années mais de façon assez basiques et je suis un peu perdu dans le code.

Je m'explique :

Je souhaite copier une ligne dont on trouve le mot "Pôle 1" dans l'onglet ayant le même nom, puis "Pôle 2" jusque "Pôle 5".

En cherchant sur le forum, j'ai trouvé quelque chose qui me plaisait et que j'ai pu modifier pour mon besoin.

Cependant le code supprime la ligne copier alors que je voudrais la laisser dans le premier onglet.

J'ai essayé de supprimer la ligne Rows(L1).Delete mais du coup on copie toujours la même ligne.

Si quelqu'un peut m'aider ça serait vraiment super sympa.

Je vous mets le fichier en copie

 

[youky(BJ)]

Bonjour
voir si c'est le résultat attendu.
Bruno

Sub Extrait()
For lig = 4 To [A65536].End(3).Row
onglet = Cells(lig, 3).Text
bas = Sheets(onglet).[A65000].End(3).Row + 1
Sheets(onglet).Range("A" & bas & ":I" & bas).Value = _
Range("A" & lig & ":I" & lig).Value
Next
End Sub

 

[Mathieu_dup]

MErci beaucoup, ça marche au top

 

[JBARBE]

Bonjour à tous,
Essai cette macro !

Option Explicit

Sub copie()
Dim i As Long, sh As Object, j&
Application.ScreenUpdating = False
With Sheets("Donnée de base")
For j = 3 To 7
Sheets(j).Select
Range("A4:I65536").Clear
Next j
For i = 4 To 65536
If .Cells(i, 1) = "" Then
Sheets("Donnée de base").Select
Exit Sub
End If
For Each sh In Sheets
    If sh.Name = .Cells(i, 3) Then
   Range(.Cells(i, 1), .Cells(i, 9)).Copy
   sh.Select
   If Range("A4") = "" Then
   Range("A4").Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   Exit For
   Else
   Range("A3").End(xlDown).Offset(1, 0).Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   Exit For
   End If
   End If
  Next sh
Next i
End With
Application.ScreenUpdating = True
End Sub

Réponse pas vu !
Bonne journée !

 

[job75]

Bonjour Mathieu_dup, Bruno, JBARBE,

Puisqu'il s'agit de filtrer filtrons :

Sub Extrait()
Dim w As Worksheet
Application.ScreenUpdating = False
With Sheets("Donnée de base").UsedRange.Offset(2).Resize(, 9) 'adapter si nécessaire
    For Each w In Worksheets
        If w.Name <> "Accueil" And w.Name <> .Parent.Name Then
            .AutoFilter 3, w.Name 'filtre automatique
            If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
            w.Rows("4:" & w.Rows.Count).Delete 'RAZ
            .Copy w.Range("A3") 'copier-coller
            w.DrawingObjects.Delete 'supprime le bouton copié
        End If
    Next
    .AutoFilter 'retire le filtre
    .Cells(1).Copy .Cells(1) 'vide la mémoire
End With
End Sub

Attention, en C6 de la feuille "Donnée de base" il n'y a pas d'accent circonflexe sur le O...

A+

 

[job75]

Re,

Après avoir exécuté la macro et enregistré le fichier il y avait un message quand on fermait le fichier :

Cette image est trop grande et va être tronquée.

J'avoue ne pas comprendre pourquoi mais je l'évite avec .Cells(1).Copy .Cells(1) 'vide la mémoire

Edit : j'ai compris, c'est à cause du bouton "Copier N à N-1" qui est copié.

Si l'on retire ce bouton de la ligne 3 pour le mettre en lignes 1:2 le message n'apparaît pas.

Cela dit vider la mémoire est également utile si la plage copiée est très grande.

A+

 

[job75]

Bonjour le fil, le forum,

En faisant des tris c'est plus rapide :

Sub Extrait()
Dim w As Worksheet, n&
Application.ScreenUpdating = False
With Sheets("Donnée de base").UsedRange.Offset(3).Resize(, 9) 'adapter si nécessaire
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Cells(1, 10) = 1: .Columns(10).DataSeries 'numérotation en colonne J
    If .Rows.Count > 3 Then
        .Cells(1, 10) = 1
        .Columns(10).Resize(.Rows.Count - 3).DataSeries 'numérotation en colonne J
        .Resize(, 10).Sort .Columns(3), Header:=xlNo 'tri sur la colonne C
    End If
    .Resize(, 10).Sort .Columns(3), Header:=xlNo 'tri sur la colonne C
    For Each w In Worksheets
        If w.Name <> "Accueil" And w.Name <> .Parent.Name Then
            If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
            w.Rows("4:" & w.Rows.Count).Delete 'RAZ
            n = Application.CountIf(.Columns(3), w.Name)
            If n Then .Rows(Application.Match(w.Name, .Columns(3), 0)).Resize(n).Copy w.Range("A3") 'copier-coller
        End If
    Next
    .Resize(, 10).Sort .Columns(10), xlAscending, Header:=xlNo 'tri sur la olonne J pour rétablir l'ordre initial
    .Columns(10).ClearContents
End With
End Sub

Fichier joint avec un tableau de 33 000 lignes pour comparer les 3 méthodes.

Bonne journée.