MACRO SUITE EXTRACTION LISTE DEROULANTE

REGIS6460 -  
Bonjour,

Je sèche completement :un classeur avec une feuille ""FEUIL1"
Col A :CODE
Col B CLIENT
Col C Nom
J'aimerais à partir d'un filtre sur le nom, copier les lignes correspondantes vers une autre feuille (meme classeur) et renomer la feuille avec le nom
Ex choix du nom "A", recopier les lignes sur FEUIL2 et la renomer en A
Idem pour "B" vers FEUIL3, renomée en B
et ainsi de suite
Je voudrais automatiser tout ca, mais rien de fonctionne


Avez vous des idees?
Merci

4 réponses

  1.  cs_Le Pivert Contributeur
    Bonjour,

    En vba a adapter: 

    Sub For_X_to_Next_Ligne()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, Var As Variant
    Set FL1 = Worksheets("Feuil1")
    NoCol = 3 'lecture de la colonne C
    For NoLig = 1 To Range("C" & Rows.Count).End(xlUp).Row 'dernière ligne colonne C
     Var = FL1.Cells(NoLig, NoCol)
  If Var = "A" Then
           Sheets("Feuil2").Cells(NoLig, NoCol - 2).Value = FL1.Cells(NoLig, NoCol - 2).Value
            Sheets("Feuil2").Cells(NoLig, NoCol - 1).Value = FL1.Cells(NoLig, NoCol - 1).Value
             End If
            Next
    Set FL1 = Nothing
   Sheets("Feuil2").Name = "A"
End Sub


    on peut le faire avec des InputBox comme ceci: 

    Sub For_X_to_Next_Ligne()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, var As Variant
Dim nom As String
Dim feuille As String
nom = InputBox("Saisie du nom a rechercher : ", "NOM", "A")
feuille = InputBox("Saisie du nom de la feuille receptrice : ", "NOM Feuille", "Feuil2")
    Set FL1 = Worksheets("Feuil1")
    NoCol = 3 'lecture de la colonne C
    For NoLig = 1 To Range("C" & Rows.Count).End(xlUp).Row 'dernière ligne colonne C
     var = FL1.Cells(NoLig, NoCol)
  If var = nom Then
           Sheets(feuille).Cells(NoLig, NoCol - 2).Value = FL1.Cells(NoLig, NoCol - 2).Value
            Sheets(feuille).Cells(NoLig, NoCol - 1).Value = FL1.Cells(NoLig, NoCol - 1).Value
             End If
            Next
    Set FL1 = Nothing
   Sheets(feuille).Name = nom
End Sub


    cela permet toutes les situations sans changer le code!

    Voilà

    0
    1. REGIS6460 Auteur
      Après de petites modifs, la méthode en haut me va bien, par contre il me filtre bien les nom et me les recopies sur une nouvelle feuille mais en laissant les lignes vides qui ne correspondent pas au filtre.
      Ex : LIGNE 1-2 , A
      LIGNE 3 reste vide car <>A
      LIGNE 4 , A
      LIGNE 5-6 reste vide car <>A
      Que rajouter pour regrouper la selection?
      Sinon reste ok pour mes besoins

      Merci
      0
      1. cs_Le Pivert Contributeur
        C'est normal, la copie se fait sur les même lignes 

         Sheets(feuille).Cells(NoLig, NoCol - 2).Value = FL1.Cells(NoLig, NoCol - 2).Value
            Sheets(feuille).Cells(NoLig, NoCol - 1).Value = FL1.Cells(NoLig, NoCol - 1).Value


        Ceux sont les mêmes numéros de lignes

        Il faut donc faire une boucle pour supprimer les lignes vides!

        j'ai un peu de temps, voici la boucle qui part de la dernière ligne vers le haut a adapter: 

        Sub deleteline()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, var As Variant
    Set FL1 = Worksheets("Feuil2")
    NoCol = 1 'lecture de la colonne A
    For NoLig = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1 'boucle en commençant par le bas
     var = FL1.Cells(NoLig, NoCol)
  If var = "" Then
             Rows(NoLig & ":" & NoLig).Delete Shift:=xlUp
     End If
            Next
    Set FL1 = Nothing
 End Sub


        Voilà a intégrer dans l'autre boucle avant le renommage de la feuille

        @+
        0
      2. cs_Le Pivert Contributeur
        Après une nuit de repos, voilà beaucoup plus simple: 

        Sub For_X_to_Next_Ligne()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, Var As Variant
Dim ligne As Integer
ligne = 1 '1ère ligne de la feuil2
    Set FL1 = Worksheets("Feuil1")
    NoCol = 3 'lecture de la colonne C
    For NoLig = 1 To Range("C" & Rows.Count).End(xlUp).Row 'dernière ligne colonne C
     Var = FL1.Cells(NoLig, NoCol)
  If Var = "A" Then
           Sheets("Feuil2").Cells(ligne, NoCol - 2).Value = FL1.Cells(NoLig, NoCol - 2).Value
            Sheets("Feuil2").Cells(ligne, NoCol - 1).Value = FL1.Cells(NoLig, NoCol - 1).Value
            ligne = ligne + 1
             End If
            Next
    Set FL1 = Nothing
   Sheets("Feuil2").Name = "A"
End Sub


        @+ Le Pivert
        0
    2. REGIS6460 Auteur
      Bonjour

      Déjà pas mal avancé avec votre aide, par contre le seul souci c'est que je dois connaitre les noms, ce qui ne sera pas toujours le cas.
      Ces noms etant inscrit dans la macro (ici A,B....)
      Une solution pour aller cherche le premier nom de la liste de choix, faire les copie sur autre feuille (copie et mise enforme ok de ce cote), et passer au nom suivant .....

      Régis
      0
      1. cs_Le Pivert Contributeur
        La solution démarrer la macro au double clic sur le nom comme ceci,

        Se mettre sur la feuille concernée(Feuil1 par ex) faire Alt F11 pour accèder au module de cette feuille et mettre ce code: 

        Option Explicit
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, Var As Variant
Dim nom As String
Dim feuille As String
Dim ligne As Integer
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C:C")) Is Nothing Then
On Error Resume Next
If Target.Value = "" Then Exit Sub
nom = Target.Value
For_X_to_Next_Ligne
End If
End Sub
Sub For_X_to_Next_Ligne()
ligne = 1 '1ère ligne de la feuil2
feuille = InputBox("Saisie du nom de la feuille receptrice : ", "NOM Feuille", "Feuil2")
    Set FL1 = Worksheets("Feuil1")
    NoCol = 3 'lecture de la colonne C
    For NoLig = 1 To Range("C" & Rows.Count).End(xlUp).Row 'dernière ligne colonne C
     Var = FL1.Cells(NoLig, NoCol)
  If Var = nom Then
           Sheets(feuille).Cells(ligne, NoCol - 2).Value = FL1.Cells(NoLig, NoCol - 2).Value
            Sheets(feuille).Cells(ligne, NoCol - 1).Value = FL1.Cells(NoLig, NoCol - 1).Value
             ligne = ligne + 1
             End If
            Next
    Set FL1 = Nothing
   Sheets(feuille).Name = nom
End Sub


        Voilà c'est simple
        0
      2. cs_Le Pivert Contributeur
        Voici une autre manière en créant une feuille avec le nom comme ceci: 

        Option Explicit
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, Var As Variant
Dim nom As String
Dim feuille As Worksheet
Dim ligne As Integer
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C:C")) Is Nothing Then
On Error Resume Next
If Target.Value = "" Then Exit Sub
nom = Target.Value
For_X_to_Next_Ligne
End If
End Sub
Sub For_X_to_Next_Ligne()
ligne = 1 '1ère ligne de la nouvelle feuille
 Set feuille = Sheets.Add(After:=Sheets(Sheets.Count)) 'se place en dernier
feuille.Name = nom
    Set FL1 = Worksheets("Feuil1")
    NoCol = 3 'lecture de la colonne C
    For NoLig = 1 To Range("C" & Rows.Count).End(xlUp).Row 'dernière ligne colonne C
     Var = FL1.Cells(NoLig, NoCol)
  If Var = nom Then
           Sheets(nom).Cells(ligne, NoCol - 2).Value = FL1.Cells(NoLig, NoCol - 2).Value
            Sheets(nom).Cells(ligne, NoCol - 1).Value = FL1.Cells(NoLig, NoCol - 1).Value
             ligne = ligne + 1
             End If
            Next
    Set FL1 = Nothing
  End Sub


        a toi de choisir

        @+ Le Pivert
        0
    3. michel_m Contributeur
      Bonjour,

      Ci joint proposition
      on ajoute la feuille au nom choisi ("A") et au copie les code et les client afférant au nom choisi. On teste au début si le nom choisi existe bien dans la colonne "nom" avec la possibilité de rectifier l'erreur.
      j'ai pris un inputname comme l'a proposé Lepivert que je salue, mais il aurait été peut-être intéressant de le faire par un formulaire avec la liste des différents noms

      mais tu n'as pas mentionné si ta liste pouvait évoluer ( nouveaux "A" par ex) ce qui changerait pas mal de choses !

      https://mon-partage.fr/f/t5GQjt3s/
      0
      1. REGIS6460 Auteur
        je vais tester, par contre effectivement la nombre de nom peut evoluer et changer
        0