XL 2016 creer des feuilles dans un classeur portant les noms des valeurs dans une colonne sans doublons

[djedjeto]

bon chers amis. j'ai un petit souci . je suis nouveau dans l'utilisation des codes vba. j'ai un classeur qui contient des données avec doublons dans une colonne . ce que j'aimerais c'est de creer directement d'autres feuilles qui porteront le nom des valeurs contenues dans ma colonne. je joints le fichier. Aidez moi.

 

[JHA]

Bonjour à tous,

Un essai par formule

JHA

 

[djedjeto]

Bonjour à tous,

Un essai par formule

JHA

merci mon frere. mais ce que je veux c'est d'inserer dans le classeur automatiquement des feuilles portant les noms à partir des données de la colonnes A

 

[djedjeto]

merci beaucoup. j'ai pu trouver une solution

Sub ventiler_tableau()

Dim DernièreLigne As Long
Dim TabColonne() As Variant
Dim TabColonneSansDoublons() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim nomfeuille As Variant
'MsgBox "Enter ComboBox1_Click" & " " & " ListIndex = " & Me.ComboBox1.ListIndex
With ThisWorkbook.Worksheets("liste")
DernièreLigne = .Range("A" & Rows.Count).End(xlUp).Row
'S'il y a au moins une ligne de données dans la colonne
If DernièreLigne > 1 Then
'Charge listbox1
TabColonne() = .Range(Cells(2, 1), _
Cells(DernièreLigne, 1)).Value
ReDim TabColonneSansDoublons(1 To UBound(TabColonne, 1))
k = 0
'Copie les valeurs de la colonne
For i = 1 To UBound(TabColonne, 1)
'Cherche si la valeur est un doublon
For j = 1 To k
If TabColonne(i, 1) = TabColonneSansDoublons(j) Then Exit For
Next j

'La valeur n'est pas un doublon
If j > k Then
k = k + 1
'Copie la valeur dans la table des valeurs sans doublons
TabColonneSansDoublons(k) = TabColonne(i, 1)
'Redimensionne la tables des valeurs sans doublons si nécessaire
nomfeuille = TabColonneSansDoublons(k)
MsgBox (nomfeuille)
ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = nomfeuille

End If
Next i

'If k < UBound(TabColonneSansDoublons) Then ReDim Preserve TabColonneSansDoublons(1 To k)

End If
End With

End Sub

 

[ChTi160]

Bonsoir
Bonsoir le Fil ,le Forum
une autre approche

Sub ventiler()
Dim ws As Worksheet
Dim ShtName As String
Dim Tablo
Dim DerLgn As Integer
Dim Lgn As Integer
Dim C
Application.ScreenUpdating = False
Set C = New Collection
With Worksheets("liste")
DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range(.Cells(1, 1), .Cells(DerLgn, 2))
      .Sort key1:=.Cells(2, 1), order1:=xlAscending, Header:=xlYes
  Tablo = .Value
End With
On Error Resume Next
For Lgn = 2 To UBound(Tablo, 1)
ShtName = Tablo(Lgn, 1)
          C.Add ShtName, CStr(ShtName)
  If Err.Number = 0 Then   
   If Not Feuille_Existe(ShtName) And ShtName <> "" Then
    Sheets.Add Count:=1, after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = ShtName
   End If
  End If
Err.Clear
Next
End With
Worksheets("liste").Activate
set C=Nothing
Application.ScreenUpdating = True
End Sub

Function Feuille_Existe(ShtName)
Feuille_Existe = False
On Error Resume Next
   Set s = Worksheets(ShtName)
   If Err.Number = 0 Then Feuille_Existe = True
On Error GoTo 0
End Function

je pense que lorsque l'on crée des feuilles , c'est pour y mettre quelque Chose Lol
Bonne fin de Soirée
Jean marie

 

[djedjeto]

Bonsoir
Bonsoir le Fil ,le Forum
une autre approche

Sub ventiler()
Dim ws As Worksheet
Dim ShtName As String
Dim Tablo
Dim DerLgn As Integer
Dim Lgn As Integer
Dim C
Application.ScreenUpdating = False
Set C = New Collection
With Worksheets("liste")
DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range(.Cells(1, 1), .Cells(DerLgn, 2))
      .Sort key1:=.Cells(2, 1), order1:=xlAscending, Header:=xlYes
  Tablo = .Value
End With
On Error Resume Next
For Lgn = 2 To UBound(Tablo, 1)
ShtName = Tablo(Lgn, 1)
          C.Add ShtName, CStr(ShtName)
  If Err.Number = 0 Then  
   If Not Feuille_Existe(ShtName) And ShtName <> "" Then
    Sheets.Add Count:=1, after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = ShtName
   End If
  End If
Err.Clear
Next
End With
Worksheets("liste").Activate
set C=Nothing
Application.ScreenUpdating = True
End Sub

Function Feuille_Existe(ShtName)
Feuille_Existe = False
On Error Resume Next
   Set s = Worksheets(ShtName)
   If Err.Number = 0 Then Feuille_Existe = True
On Error GoTo 0
End Function

je pense que lorsque l'on crée des feuilles , c'est pour y mettre quelque Chose Lol
Bonne fin de Soirée
Jean marie

Merci infinimement mon frère c'est exactement ce que je voulais que tu as fait. tu es le meilleur. peut tu peux aussi m'aider au cas ou sur chaque feuille je pourrai recuperer les données la concernant à partir de la feuille liste. merci infiniment

 

[job75]

Bonjour djedjeto, JHA, ChTi160,

Voyez le fichier joint et cette macro très classique :

Sub Ventiler()
Dim d As Object, tablo, i&, nf$, w As Worksheet
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
On Error Resume Next 'si une feuille n'existe pas
With Sheets("Liste").[A1].CurrentRegion
    tablo = .Value 'matrice, plus rapide
    For i = 2 To UBound(tablo)
        nf = CStr(tablo(i, 1))
        If nf <> "" And Not d.exists(nf) Then
            d(nf) = ""
            Set w = Nothing
            Set w = Sheets(nf)
            If w Is Nothing Then
                Set w = Sheets.Add(After:=Sheets(Sheets.Count))
                w.Name = nf
            End If
            w.Cells.Delete 'RAZ
            .AutoFilter 1, nf
            .SpecialCells(xlCellTypeVisible).Copy w.Cells(1)
            .AutoFilter
            w.Columns.AutoFit 'ajustement largeurs
        End If
    Next
    .Parent.Activate
End With
End Sub

A+

 

[djedjeto]

Bonjour djedjeto, JHA, ChTi160,

Voyez le fichier joint et cette macro très classique :

Sub Ventiler()
Dim d As Object, tablo, i&, nf$, w As Worksheet
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
On Error Resume Next 'si une feuille n'existe pas
With Sheets("Liste").[A1].CurrentRegion
    tablo = .Value 'matrice, plus rapide
    For i = 2 To UBound(tablo)
        nf = CStr(tablo(i, 1))
        If nf <> "" And Not d.exists(nf) Then
            d(nf) = ""
            Set w = Nothing
            Set w = Sheets(nf)
            If w Is Nothing Then
                Set w = Sheets.Add(After:=Sheets(Sheets.Count))
                w.Name = nf
            End If
            w.Cells.Delete 'RAZ
            .AutoFilter 1, nf
            .SpecialCells(xlCellTypeVisible).Copy w.Cells(1)
            .AutoFilter
            w.Columns.AutoFit 'ajustement largeurs
        End If
    Next
    .Parent.Activate
End With
End Sub

A+

merci infiniment. Parfait. tu m'as sauvé. infiniment merci