XL 2016 Code VBA

[tara_xacum]

Bonjour,
J'ai besoin de créer un code VBA pour copier certaines lignes de la feuille 1 dans l'onglet correspondant;
A chaque fois que Ana est notée dans la colonne D, il faut que cette ligne se copie dans l'onglet Ana. Pareil pour Bob et Jack
Je voudrai aussi garder la ligne 1 dans tous mes onglets.
Les données de la feuille 1 ne doivent pas être enlevées.

Merci pour votre aide

 

[vgendron]

Bonjour

une proposition ci-dessous

Sub dispatch()
Dim TabData() As Variant
Application.ScreenUpdating = False
With Sheets("feuil1")
    TabData = .UsedRange.Value
End With

For i = LBound(TabData, 1) + 1 To UBound(TabData, 1)
    With Sheets(TabData(i, 4))
        For j = LBound(TabData, 2) To UBound(TabData, 2)
            .Range("A" & .Rows.Count).End(xlUp).Offset(1 - IIf(j <> 1, 1, 0), j - 1) = TabData(i, j)
        Next j
    End With
Next i
Application.ScreenUpdating = True
End Sub

 

[Robert]

Bonjour le fil, bonjour le forum,

Une autre approche où tu peux relancer la macro plusieurs fois sans avoir de doublons :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Worksheets("Feuil1") 'définit l'onglet OS
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For Each O In Sheets 'boucle sur tous les onglets O du classeur
    Application.DisplayAlerts = False 'empêche les messages d'Excel
    If Not O.Name = "Feuil1" Then O.Delete 'si le nom de l'onglet de la boucle n'est pas "Feuil1", supprime l'onglet
    Application.DisplayAlerts = True 'autorise les messages d'Excel
Next O 'prochain onglet de la boucle
For I = 2 To UBound(TV, 1) 'boucle surt toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set O = Worksheets(TV(I, 4)) 'définit l'onglet O avec le nom (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Set O = Worksheets.Add(After:=Sheets(Sheets.Count)) 'définit l'onglet O en ajoutant un onglet vierge en dernière position
        O.Name = TV(I, 4) 'renome l'onglet avec le nom
    End If 'fin de la condition
    O.Range("A1").Resize(1, UBound(TV, 2)).Value = Application.Index(TV, 1) 'renvoie la première ligne de TV
    Set DEST = O.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellue de destination DEST
    If TV(I, 4) = O.Name Then DEST.Resize(1, UBound(TV, 2)).Value = Application.Index(TV, I) 'renvoie la ligne I de TV dans DEST
Next I 'prochaine ligne de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

 

[tara_xacum]

Bonjour

une proposition ci-dessous

Sub dispatch()
Dim TabData() As Variant
Application.ScreenUpdating = False
With Sheets("feuil1")
    TabData = .UsedRange.Value
End With

For i = LBound(TabData, 1) + 1 To UBound(TabData, 1)
    With Sheets(TabData(i, 4))
        For j = LBound(TabData, 2) To UBound(TabData, 2)
            .Range("A" & .Rows.Count).End(xlUp).Offset(1 - IIf(j <> 1, 1, 0), j - 1) = TabData(i, j)
        Next j
    End With
Next i
Application.ScreenUpdating = True
End Sub

Bonjour,
Ce code fonctionne très bien. Mais lorsque j'essaie de l'appliquer à un autre fichier, certaines lignes ne se copient pas, cela met Erreur d'exécution 9.

Merci

 

[job75]

Bonjour tara_xacum, vgendron, Robert,

Ici le filtre automatique s'impose, dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, col%
Set F = Sheets("Feuil1") 'à adapter
col = 4 'colonne des noms, à adapter
If Sh.Name = F.Name Then Exit Sub
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
With F.[A1].CurrentRegion
    .AutoFilter col, Sh.Name 'filtre automatique
    .Copy Sh.[A1]
    .AutoFilter 'ôte le filtre
End With
End Sub

La macro se déclenche quand on active une feuille.

Edit : j'avais oublié la RAZ.

A+

 

[job75]

Pour tester j'ai recopié le tableau A2: D6 sur 100 000 lignes.

Durées d'exécution chez moi sur Win 11 Excel 2019 :

- Jack et Ana => 0,7 seconde

- Bob => 1,2 seconde.

 

[job75]

Quant à votre fichier du post #4 :

- supprimez la ligne 1 qui ne sert à rien

- renseignez toute la ligne des titres

- dans la macro => col = 17

Bonne nuit.

 

[job75]

Si l'on veut récupérer les hauteurs des lignes utilisez ce fichier (3) avec ;

With F.[A1].CurrentRegion.EntireRow

Re bonne nuit.

 

[job75]

Et le fichier (4) si vous tenez à cette ligne 1 qui ne sert à rien :

With F.[A1].CurrentRegion.EntireRow.Offset(1)

 

[tara_xacum]

Merci à vous, cela fonctionne et c'est parfait comme toujours