Transfert feuille vers 5 autres selon critère d'1 colonne
Bonjour à toutes et à tous, voici mon premier message sur le forum,
Je débute en vba et je n'arrive pas à trouver de solution à ce problème.
Je dispose d'une feuille excel (feuille 1) contenant la liste des inscrits à une compétion cycliste et j'aimerais par macro transférer certaines colonnes d'une ligne vers 5 autres feuilles sous condition que la catégorie de la feuille 1 (colonne K) corresponde à l'onglet Emargement de cette catégorie.
Pour l'instant le meilleur résultat obtenu est de recopier les lignes entières avec ce code:
Sub rempliremargement()
Dim plage As Range, Cel As Range
'stop rafraichissement ecran
Application.ScreenUpdating = False
'valeur a chercher
valcherch = "Prélicencié"
With Worksheets("Engagés FFC")
'derniere cellule colonne K
derlig = .Range("K" & Rows.Count).End(xlUp).Row
'defintion plage a tester en memoire
Set plage = .Range("K3:K" & derlig)
End With
derlig = 0
With Worksheets("Emarg Prélicenciés")
'test plage
For Each Cel In plage
If Cel = valcherch Then
'premiere cellule vide apres derniere non vide colonne K
derlig = .Range("k" & Rows.Count).End(xlUp).Row + 1
'premier lancement
If derlig = 2 Then
derlig = 3
End If
'copy ligne entiere
Cel.col.Copy .Range("A" & derlig)
End If
Next Cel
End With
'valeur a chercher
valcherch = "Poussin"
With Worksheets("Engagés FFC")
'derniere cellule colonne K
derlig = .Range("K" & Rows.Count).End(xlUp).Row
'defintion plage a tester en memoire
Set plage = .Range("K3:K" & derlig)
End With
derlig = 0
With Worksheets("Emarg Poussins")
'test plage
For Each Cel In plage
If Cel = valcherch Then
'premiere cellule vide apres derniere non vide colonne K
derlig = .Range("K" & Rows.Count).End(xlUp).Row + 1
'premier lancement
If derlig = 2 Then
derlig = 3
End If
'copy ligne entiere
Cel.EntireRow.Copy .Range("A" & derlig)
End If
Next Cel
End With
derlig = 0
With Worksheets("Emarg Pupilles")
'test plage
For Each Cel In plage
If Cel = valcherch Then
'premiere cellule vide apres derniere non vide colonne K
derlig = .Range("K" & Rows.Count).End(xlUp).Row + 1
'premier lancement
If derlig = 2 Then
derlig = 3
End If
'copy ligne entiere
Cel.EntireRow.Copy .Range("A" & derlig)
End If
Next Cel
End With
'valeur a chercher
valcherch = "Benjamin"
With Worksheets("Engagés FFC")
'derniere cellule colonne K
derlig = .Range("K" & Rows.Count).End(xlUp).Row
'defintion plage a tester en memoire
Set plage = .Range("K3:K" & derlig)
End With
derlig = 0
With Worksheets("Emarg Benjamins")
'test plage
For Each Cel In plage
If Cel = valcherch Then
'premiere cellule vide apres derniere non vide colonne K
derlig = .Range("k" & Rows.Count).End(xlUp).Row + 1
'premier lancement
If derlig = 2 Then
derlig = 3
End If
'copy ligne entiere
Cel.EntireRow.Copy .Range("A" & derlig)
End If
Next Cel
End With
'valeur a chercher
valcherch = "Minime"
With Worksheets("Engagés FFC")
'derniere cellule colonne K
derlig = .Range("K" & Rows.Count).End(xlUp).Row
'defintion plage a tester en memoire
Set plage = .Range("K3:K" & derlig)
End With
derlig = 0
With Worksheets("Emarg Minimes")
'test plage
For Each Cel In plage
If Cel = valcherch Then
'premiere cellule vide apres derniere non vide colonne K
derlig = .Range("K" & Rows.Count).End(xlUp).Row + 1
'premier lancement
If derlig = 2 Then
derlig = 3
End If
'copy ligne entiere
Cel.EntireRow.Copy .Range("A" & derlig)
End If
Next Cel
End With
'rafraichissement ecran
Application.ScreenUpdating = True
End SubOr je souhaiterais ne transférer que les colonnes E,F,N,G,K et L correspondant à la catégorie figurant en colonne K.
Pour corser le tout j'aimerais que les données apparaissent dans un tableau comme affiché sous l'onglet "Emarg Minimes"
Si quelqu'un à la moindre piste à m'indiquer, je suis preneur.
Mon problème est si compliqué que ça?
Je n'ai pas de notion sur la complexité de ma demande, j'ai tenté une autre macro qui ne fonctionne pas , mais pourrait peut être donner une piste à quelqu'un?
' Synchronisation avec emargement
Sub mamacro()
'définition des variables
Dim FFC As Worksheet
Dim EMARG1 As Worksheet
Dim EMARG2 As Worksheet
Dim EMARG3 As Worksheet
Dim EMARG4 As Worksheet
Dim EMARG5 As Worksheet
Dim Coureur As String
Dim UCI As String
Dim NFFC As String
Dim CLUB As String
Dim SX As String
Dim CATEGORIE As String
Dim CAT As Integer
Dim EMARG As Worksheet
Dim ligne As Integer
Set FFC = Worksheets("Engagés FFC")
Set EMARG1 = Worksheets("Emarg Prélicenciés")
Set EMARG2 = Worksheets("Emarg Poussins")
Set EMARG3 = Worksheets("Emarg Pupilles")
Set EMARG4 = Worksheets("Emarg Benjamins")
Set EMARG5 = Worksheets("Emarg Minimes")
For ligne = 3 To 302
Coureur = FFC.Cells(ligne, "E")
UCI = FFC.Cells(ligne, "F")
NFFC = FFC.Cells(ligne, "N")
CLUB = FFC.Cells(ligne, "G")
SX = FFC.Cells(ligne, "L")
Next
FFC.Unprotect
FFC.Cells(ligne, "K") = CAT
If Len(FFC.Cells(ligne, "K")) = CAT Then
Iteration = ligne
End If
If CAT = "Prélicencié" Then
EMARG = EMARG1
End If
If CAT = "Poussin" Then
EMARG = EMARG2
End If
If CAT = "Pupille" Then
EMARG = EMARG3
End If
If CAT = "Benjamin" Then
EMARG = EMARG4
End If
If CAT = "Minime" Then
EMARG = EMARG5
End If
ligne = 7
EMARG.Cells(Iteration, "A") = Dossard
EMARG.Cells(Iteration, "B") = Coureur
EMARG.Cells(Iteration, "C") = UCI
EMARG.Cells(Iteration, "D") = NFFC
EMARG.Cells(Iteration, "E") = CLUB
EMARG.Cells(Iteration, "F") = SX
EMARG.Cells(Iteration, "G") = CATEGORIE
FFC.Activate
End SubBonsoir M12,
je viens de tester votre solution qui fonctionne à merveille.
Merci beaucoup de votre aide précieuse.
De mon côté je suis rester 2jours sans chercher de solution et aujourd'hui, en m'y remettant j'ai aussi trouver un code qui fonctionne, le voici:
Sub Préparer_feuilles_émargement()
'Macro pour répartir les engagés de l'épreuve dans les les feuilles d'émargements de chaque catégorie
Dim ws As String
Dim lipré As Integer, lipou As Integer, lipup As Integer, liben As Integer, limin As Integer
Application.ScreenUpdating = False
ws = "Engagés FFC"
Sheets("Engagés FFC").Unprotect
lipré = 7
lipou = 7
lipup = 7
liben = 7
limin = 7
With Sheets(ws)
For Each Cel In .Range("k3", Range("k65536").End(xlUp))
Select Case Cel
Case Is = "Prélicencié"
Sheets("Emarg Prélicenciés").Unprotect
With Sheets("Emarg Prélicenciés")
.Cells(lipré, 2) = Sheets(ws).Cells(Cel.Row, 5)
.Cells(lipré, 3) = Sheets(ws).Cells(Cel.Row, 7)
.Cells(lipré, 4) = Sheets(ws).Cells(Cel.Row, 6)
.Cells(lipré, 5) = Sheets(ws).Cells(Cel.Row, 14)
.Cells(lipré, 6) = Sheets(ws).Cells(Cel.Row, 11)
.Cells(lipré, 7) = Sheets(ws).Cells(Cel.Row, 12)
lipré = lipré + 1
Sheets(ws).Cells(1, "L") = lipré - 7
Sheets("Emarg Prélicenciés").Protect
End With
Case Is = "Poussin"
With Sheets("Emarg Poussins")
.Cells(lipou, 2) = Sheets(ws).Cells(Cel.Row, 5)
.Cells(lipou, 3) = Sheets(ws).Cells(Cel.Row, 7)
.Cells(lipou, 4) = Sheets(ws).Cells(Cel.Row, 6)
.Cells(lipou, 5) = Sheets(ws).Cells(Cel.Row, 14)
.Cells(lipou, 6) = Sheets(ws).Cells(Cel.Row, 11)
.Cells(lipou, 7) = Sheets(ws).Cells(Cel.Row, 12)
lipou = lipou + 1
Sheets(ws).Cells(2, "L") = lipou - 7
End With
Case Is = "Pupille"
With Sheets("Emarg Pupilles")
.Cells(lipup, 2) = Sheets(ws).Cells(Cel.Row, 5)
.Cells(lipup, 3) = Sheets(ws).Cells(Cel.Row, 7)
.Cells(lipup, 4) = Sheets(ws).Cells(Cel.Row, 6)
.Cells(lipup, 5) = Sheets(ws).Cells(Cel.Row, 14)
.Cells(lipup, 6) = Sheets(ws).Cells(Cel.Row, 11)
.Cells(lipup, 7) = Sheets(ws).Cells(Cel.Row, 12)
lipup = lipup + 1
Sheets(ws).Cells(3, "L") = lipup - 7
End With
Case Is = "Benjamin"
With Sheets("Emarg Benjamins")
.Cells(liben, 2) = Sheets(ws).Cells(Cel.Row, 5)
.Cells(liben, 3) = Sheets(ws).Cells(Cel.Row, 7)
.Cells(liben, 4) = Sheets(ws).Cells(Cel.Row, 6)
.Cells(liben, 5) = Sheets(ws).Cells(Cel.Row, 14)
.Cells(liben, 6) = Sheets(ws).Cells(Cel.Row, 11)
.Cells(liben, 7) = Sheets(ws).Cells(Cel.Row, 12)
liben = liben + 1
Sheets(ws).Cells(4, "L") = liben - 7
End With
Case Is = "Minime"
With Sheets("Emarg Minimes")
.Cells(limin, 2) = Sheets(ws).Cells(Cel.Row, 5)
.Cells(limin, 3) = Sheets(ws).Cells(Cel.Row, 7)
.Cells(limin, 4) = Sheets(ws).Cells(Cel.Row, 6)
.Cells(limin, 5) = Sheets(ws).Cells(Cel.Row, 14)
.Cells(limin, 6) = Sheets(ws).Cells(Cel.Row, 11)
.Cells(limin, 7) = Sheets(ws).Cells(Cel.Row, 12)
limin = limin + 1
Sheets(ws).Cells(5, "L") = limin - 7
End With
End Select
Next
End With
End SubBonjour,
Une autre proposition.
Avec une feuille Modèle à mettre en forme.
A te relire.
Cdlt.
Monsieur Jean éric,
Chapeau bas!
J'aimerais juste avoir quelques lignes vierge en plus en cas d'inscription sur la ligne de départ.
Mais quelle classe ce code!
Monsieur Jean Eric,
C'est parfait!
Il me faut plusieurs semaines de lecture et de recherche pour obtenir ce que je veux faire et là vous me proposez une solution en quelques heures! je n'en revient pas.
Je regarderai votre code dans la journée afin de tenter de le comprendre au mieux et de l'adapter à une nouvelle problématique: réaliser la même opération sur une seule feuille qui regroupera toutes les catégories, le problème serait ici qu'a chaque changement de catégorie l'écriture se fasse sur la première ligne de la page suivante ( en conservant les 8 premières lignes de la feuille sur toutes les pages.)
Encore Merci .