VBA, fichier des lignes avec une meme cellule Résolu/Fermé

Question

Bonjour, 

Je souhaite créer une macro applicable à différentes plages de données de même type mais de longueurs différentes.

Dans la première colonne, j'ai le code produit. J'aimerais avoir un fichier (ou une feuille) par produit, qui porte le nom du produit. 

Dans la première ligne de mon fichier d'origine, j'ai le nom des colonnes que je souhaite conserver dans chaque fichier.

Je souhaite donc que ma macro cherche dans la colonne A tous les codes qui sont les mêmes et créée un fichier (ou une feuille) comprenant toutes les lignes avec un même code pour chacun des codes.

J'espère que mon explication est claire. N'hésitez pas à me demander des précisions!




Je planche dessus depuis un bout de temps mais j'ai vraiment du mal. J'ai essayé de créer non pas des fichiers mais des feuilles. Ce code ne fonctionne pas et ne met pas la première ligne de mon fichier.



Sub creer_feuille()

A = Cells(2, 1)

Sheets.Add.Name = A


End Sub

'Je suis obligée de faire 2 sub car la feuille nouvellement créer devient active


Sub Trier_sur_feuilles()

A = Cells(2, 1)


    If B = Columns(1).Find(What:=A, After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate is True Then Rows.Copy (Sheets("A"))


End Sub




Je vous serais vivement reconnaissante de votre aide. Je débute avec VBA et même si il y a énormément d'information sur internet, j'ai vraiment des difficultés avec ce langage! 
 



Configuration: Windows XP / Safari 534.30

Utilisateur anonyme · Answer

Bonjour, 

Voici un début :-) 


Option Explicit 

Sub Creer_Feuille() 

    Dim A As String 
    Dim Fle_Origine As String 
     
    ' Capture de la feuille active 
    Fle_Origine = ActiveSheet.Name 
     
    ' Capture de la valeur recherché 
    A = Cells(2, 1).Value 

    ' Si valeur différent de rien 
    If (A <> "") Then 
        ' Ajout d'une feuille au nom désiré 
        Sheets.Add.Name = A 
    End If 
     
    ' Retour à la feuille de départ 
    Sheets(Fle_Origine).Select 
     
    ' Ce bout ci n'est pas clair pour moi 
    ' veuillez détailler s.v.p. 
    ' Quel est la valeur de B, d'où vient cette variable ?
    If (B = Columns(1).Find(What:=A, _ 
                           After:=Cells(1, 1), _ 
                           LookIn:=xlValues, _ 
                           SearchOrder:=xlByRows, _ 
                           SearchDirection:=xlNext, _ 
                           MatchCase:=False, _ 
                           SearchFormat:=False).Activate Is True) Then 
                            
        Rows.Copy (Sheets(A)) 
         
    End If 

End Sub 
' 


Cdt 

Lupin

eriiic · Answer

Bonjour,   

Autre proposition (si j'ai bien compris la demande...) :   
Sub creerFeuilles()
    Dim nbcol As Long, lig As Long, derlig As Long, nomF As String, nlig As Long
    Dim sh1 As Worksheet, sh2 As Worksheet
    Application.ScreenUpdating = False
    Set sh1 = Worksheets("donnees")
    nbcol = [A1].End(xlToRight).Column
    derlig = [A65536].End(xlUp).Row
    For lig = 2 To derlig
        nomF = sh1.Cells(lig, 1)
        ' création de la feuille si besoin
        If Not existSh(nomF) Then
            Sheets.Add.Name = nomF
            ActiveSheet.Move After:=Worksheets(Worksheets.Count)
            sh1.Cells(1, 1).Resize(1, nbcol).Copy ActiveSheet.[A1]
        End If
        ' copie donnée
        nlig = 1
        While sh1.Cells(lig + nlig, 1) = sh1.Cells(lig, 1)
            nlig = nlig + 1
        Wend
        sh1.Cells(lig, 1).Resize(nlig, nbcol).Copy Worksheets(nomF).[A65536].End(xlUp).Offset(1, 0)
        lig = lig + nlig - 1
    Next lig
    Application.ScreenUpdating = True
    sh1.Activate
End Sub

Function existSh(nom As String) As Boolean
    ' test l'existence d'une feuille
    Dim b As Boolean
    On Error GoTo suite
    Sheets(nom).Activate
    b = True
suite:
    existSh = b
End Function


Au début je met nbcol (nombre de colonnes copiées) égal au nombre de colonnes remplies consécutives de la ligne 1. Tu peux remplacer par la valeur que tu veux.   

http://www.cijoint.fr/cjlink.php?file=cj201106/cijIHGHqGw.xls  

eric 

PS: cette macro agit sur la feuille active. Tu devrais ajouter un test au début pour reconnaitre la feuille et ne faire le traitement que si la feuille est concernée.

amdbg · Answer

Bonjour!  

Merci beaucoup de m'avoir répondu aussi vite! 

Lupin, tu as raison, il n'y a pas vraiment d'intérêt à définir B. Je souhaite juste rechercher les lignes dont la première cellule est la même et les sélectionner. 

Eric, ta macro fonctionne très bien sur ton exemple mais elle nécessite un débogage dans mon fichier, l'erreur affichée est  "Indice en dehors de la plage (erreur 9)"; au niveau de la ligne 

       Set sh2 = Worksheets(sh1.Cells(lig, 1).Value)  

J'ai rajouté 2 lignes de code pour être sûre que la feuille avec les données était sélectionnée, mais l'erreur apparaît toujours. 


Option Explicit

Sub creerFeuilles()

ActiveSheet.Name = "donnees"

    Dim nbcol As Long, lig As Long, derlig As Long ', ok As Boolean
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = ActiveSheet
    nbcol = [A1].End(xlToRight).Column
    derlig = [A65536].End(xlUp).Row
    For lig = 2 To derlig
        ' création de la feuille si besoin
        If Not existSh(sh1.Cells(lig, 1)) Then
            Sheets.Add.Name = sh1.Cells(lig, 1)
            ActiveSheet.Move After:=Worksheets(Worksheets.Count)
            sh1.Cells(1, 1).Resize(1, nbcol).Copy ActiveSheet.[A1]
        End If
        ' copie donnée
        
        Sheets("donnees").Activate
        
        Set sh2 = Worksheets(sh1.Cells(lig, 1).Value)
        sh1.Cells(lig, 1).Resize(1, nbcol).Copy sh2.[A65536].End(xlUp).Offset(1, 0)
    Next lig
End Sub

Function existSh(nom As String) As Boolean
    ' test l'existence d'une feuille
    Dim b As Boolean
    On Error GoTo suite
    Sheets(nom).Activate
    b = True
suite:
    existSh = b
End Function

VBA, fichier des lignes avec une meme cellule

3 réponses

Discussions similaires