Création macro VBA - Problème tordu

Marsh Posté le 11-04-2009 à 16:33:28

Bonjour,

Je cherche en vain à faire une macro répondant à cet objectif :
Je veux créer autant de feuilles qu'il y a de valeur différente dans une même colonne et que pour chacune de ces valeurs de la colonne la ligne correspondante soit copiée/collée dans la feuille correspondante. (C'est clair )

Par exemple :

J'ai une feuille appelée "BDD" Excel avec 6 valeurs en colonne A :

Toto
Papa
Maman
Toto
Toto
Maman

Avant tout, je les "sort" par la colonne A (ça c'est dans mes cordes)

1) je souhaite que la macro fasse une feuille pour chaque valeurs différentes de la colonne A
En gros j'ai ma feuille "BDD", ma feuille "Toto", ma feuille "Papa" et ma feuille "Maman"
(1bis La macro nomme les feuilles avec le nom de la valeur)

J'ai tenté un :
for each value in columns("A" )
Add.sheets

Mais sans succès, ça me créé une feuille et une seule

2) La macro copie/colle chaque ligne de la BDD dans le bon onglet
Dans la feuille Toto, on a donc 3 lignes (Car y a 3 toto dans la colonne A de la feuille BDD)
Dans la feuille Papa, on a donc 2 lignes (Car y a 2 Papa dans la colonne A de la feuille BDD)
Dans la feuille Maman, on a donc 1 ligne (Car y a 1 maman dans la colonne A de la feuille BDD)

J'ai tenté une boucle en comparant la value de la colonne mais sans succès

3) La BDD ne doit pas bouger (Sinon je suis viré )

Merci pour votre aide

Spoiler :

Désolé d'être nul en VBA

Message édité par greystick le 11-04-2009 à 16:34:33

---------------
Bière qui roule, bière qui mousse

Reply

Marsh Posté le 11-04-2009 à 16:33:28

Reply

Marsh Posté le 11-04-2009 à 18:43:09

Bonsoir,
vite fait pour créer les feuilles
après, tu cherches un peu pour copier les lignes .

Sub Macro1()
'
' Macro1 Macro
'

'
For lig = 1 To 65000

If Sheets("feuil1" ).Cells(lig, 1) = "" Then Exit Sub
lenom = Sheets("feuil1" ).Cells(lig, 1)
yapas = True
For Each sh In ThisWorkbook.Sheets
If sh.Name = lenom Then
yapas = False
Exit For
End If
Next
If yapas Then
Sheets("Feuil2" ).Select 'ou une autre
Sheets.Add
ActiveSheet.Name = lenom

End If
'..copier la ligne après la dernière ligne
Next
End Sub

Cordialement

En espèrant que cela fonctionne

Reply

Marsh Posté le 11-04-2009 à 18:52:43

Salut,

Option Explicit

Sub GenererFeuilles()
Dim i As Long, sNomFeuille As String
Dim LastRow As Long, LastRowSh As Long

Application.ScreenUpdating = False

LastRow = ShBDD.Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To LastRow
sNomFeuille = ShBDD.Cells(i, 1)
If ExistenceFeuille(sNomFeuille) = False Then
Sheets.Add
ActiveSheet.Name = sNomFeuille
ShBDD.Cells(i, 2).Copy Destination:=ActiveSheet.Cells(1, 1)
Else
LastRowSh = Sheets(sNomFeuille).Range("A" & Rows.Count).End(xlUp).Row
ShBDD.Cells(i, 2).Copy Destination:=Sheets(sNomFeuille).Cells(LastRowSh + 1, 1)
End If
Next i

ShBDD.Move Before:=Sheets(1)
Application.ScreenUpdating = True
End Sub

Private Function ExistenceFeuille(ByVal sNomFeuille As String) As Boolean
On Error Resume Next
ExistenceFeuille = Sheets(sNomFeuille).Name <> ""
End Function

On pourra incorporer une routine de vérification de la validité du nom des feuilles

Private Function NomFeuilleValide(ByVal sNom As String) As String
Const CaracInterdits As String = ":/\?*[]"
Dim i As Integer, Car As String * 1

Select Case Len(sNom)
Case 0: Exit Function
Case Is > 31: sNom = Left(sNom, 31)
End Select

For i = 1 To Len(CaracInterdits)
Car = Mid(CaracInterdits, i, 1)
sNom = Replace(sNom, Car, "" )
Next i

NomFeuilleValide = Trim(sNom)
End Function

et pourquoi pas une routine de tri très sommaire

Private Sub TriFeuilles()
Dim Cpt As Long, Cpt2 As Long
Dim NbSh As Long

NbSh = Sheets.Count

For Cpt = 1 To NbSh
For Cpt2 = Cpt To NbSh
If UCase(Sheets(Cpt2).Name) < UCase(Sheets(Cpt).Name) Then
Sheets(Cpt2).Move Before:=Sheets(Cpt)
End If
Next Cpt2
Next Cpt

ShBDD.Move Before:=Sheets(1)
End Sub

Message édité par kiki29 le 12-04-2009 à 09:18:36

Reply

Marsh Posté le 13-04-2009 à 18:27:13

Bon bah nickel
Merci pour tout ça marche !

Reply

Création macro VBA - Problème tordu

Sujets relatifs:

Leave a Replay