Copier/Coller selon un critère sur de nouvelles feuilles
Bonjour,
Je souhaiterais à partir de ma base de donnée (feuille 1) copier des lignes selon le critère "centre" et les coller selon le centre sur des nouvelles feuilles.
J'ai déja une base concernant ma macro mais il me dit qu'il y a une erreur que je ne trouve pas.
Voici ma macro:
Option Explicit
Sub Dispatcher()
Dim CptLig As Integer, LigDst As Integer '***** declaration d'une variable supplementaire
Dim Feuille As Worksheet
For CptLig = 2 To Feuil1.Range("I65536").End(xlUp).Row
Set Feuille = Nothing
If Not FeuilleExiste(Worksheets(1).Range("" & CptLig).Value) Then
Set Feuille = Sheets.Add(After:=Worksheets(Worksheets.Count))
Feuille.Name = Feuil1.Range("" & CptLig).Value
Feuil1.Rows("1").Copy Destination:=Feuille.Rows("1")
End If
If Feuille Is Nothing Then Set Feuille = Sheets(Feuil1.Range("GNY" & CptLig).Value)
LigDst = Feuille.Range("A65536").End(xlUp).Row + 1 '**** recherche de la derniere ligne
Feuil1.Rows(CptLig).Copy Destination:=Feuille.Range("A" & LigDst) '**** integration de la variable dans l'instruction
Next CptLig
Feuil1.Activate
End Sub
Function FeuilleExiste(Nom As String) As Boolean
Dim Feuille As Worksheet
FeuilleExiste = False
For Each Feuille In Worksheets
If LCase(Feuille.Name) = LCase(Nom) Then
FeuilleExiste = True
Exit For
End If
Next Feuille
End Function
Voici le fichier sur lequel je travaille
Bonjour,
Pourrais-tu nous dire ce que tu cherches à obtenir, il y a peut être d'autres moyens que les macros...
PS : tu indiques que tu travailles sous une version 2010, mais le fichier joint est au format 2003. Est-ce normal ?
Cordialement, Daniel
Bonjour,
Je souhaite extraire ou copier les lignes selon les centres et les copier sur d'autres feuilles du classeur selon le centre.
Exemple: les lignes du centre "GBO" de la feuille 1 soit coller sur une nouvelle feuille du nom de "GBO". Une fois cette opération faite, les lignes copiées ne doivent plus apparaître sur la feuille 1
Je ne sais pas si c'est clair ??
Bonjour,
As-tu exploré les fonctionnalités de base d'Excel : les filtres, et surtout les filtres avances.
Ces derniers réalisent grosso modo ce que tu veux faire, et sont beaucoup plus faciles à automatiser...
Nul doute que quelqu'un, sur ce forum, va te rédiger la macro souhaitée. Mais, d'une part, cela revient souvent à réinventer l'eau chaude, d'autre part, cela ne favorise pas l'acquisition de l'autonomie...
Cordialement, Daniel
Voici ce que j'ai trouvé:
Option Explicit
Sub Dispatcher()
Dim CptLig As Integer, LigDst As Integer '***** declaration d'un variable supplementaire
Dim Feuille As Worksheet
For CptLig = 2 To Feuil1.Range("I65536").End(xlUp).Row
Set Feuille = Nothing
If Not FeuilleExiste(Feuil1.Range("I" & CptLig).Value) Then
Set Feuille = Sheets.Add(After:=Worksheets(Worksheets.Count))
Feuille.Name = Feuil1.Range("I" & CptLig).Value
Feuil1.Rows("1:2").Copy Destination:=Feuille.Rows("1:2")
End If
If Feuille Is Nothing Then Set Feuille = Sheets(Feuil1.Range("I" & CptLig).Value)
LigDst = Feuille.Range("A65536").End(xlUp).Row + 1 '**** recherche de la derniere ligne
If LigDst < 2 Then LigDst = 2 '**** on verifie si on est inferieur a 2 dans ce cas on met 2
Feuil1.Rows(CptLig).Copy Destination:=Feuille.Range("A" & LigDst) '**** integration de la variable dans l'instruction
Next CptLig
Feuil1.Activate
End Sub
Function FeuilleExiste(Nom As String) As Boolean
Dim Feuille As Worksheet
FeuilleExiste = False
For Each Feuille In Worksheets
If LCase(Feuille.Name) = LCase(Nom) Then
FeuilleExiste = True
Exit For
End If
Next Feuille
End Function
Cela fonctionne mais je voudrais maintenant supprimer des colonnes et garder le format initial