Ca devrait fonctionner
Attention a bien exécuter à partir de la feuille de base, parce que comme tu as pas mis son nom j'ai du récuperer celui de la feuille active.
Peut etre long en fonction du nombre de ligne...
J'ai pas désactivé les calculs, donc s'il y en a ça peut être encore plus long.
Code :
- Sub CopieLigne()
- Dim NbVal As Integer
- Dim I As Integer
- Dim Nom As String
- Dim feuille As String
- Dim fintab As String
- 'determine la feuille où est jouée la macro
- feuille = ActiveSheet.Name
- 'determine le nombre de ligne à vérifier
- NbVal = Application.WorksheetFunction.CountA(Worksheets(feuille).Range("$A:$A" ))
- 'Boucle sur chaque ligne
- For I = 2 To NbVal
- 'stock le contenu de la cellule pour tester sa présence en feuille
- Nom = Sheets(feuille).Cells(I, 1)
- 'vérifie si la feuille existe, si oui copie la ligne en bas du tableau existant, si non créé un nouveau tableau avec la ligne à copier
- If WsExist(Nom) = False Then
- Sheets.Add
- ActiveSheet.Name = Nom
- Sheets(feuille).Range("1:1" ).Copy Sheets(Nom).Range("A1" )
- Sheets(feuille).Range(I & ":" & I).Copy Sheets(Nom).Range("A2" )
- Else
- fintab = Sheets(Nom).Range("A" & Rows.Count).End(xlUp).Row + 1
- Sheets(feuille).Range(I & ":" & I).Copy Sheets(Nom).Range("A" & fintab)
- End If
- Next I
- MsgBox ("Terminé" )
- End Sub
- Function WsExist(Nom$) As Boolean
- On Error Resume Next
- WsExist = Sheets(Nom).Index
- End Function
|
Message édité par wago le 27-07-2017 à 00:04:57
mais avant d'en arriver là... 
Néanmoins, j'ai réussi à faire pas mal de petite chose. Par contre, je suis un peu bloqué.