XL 2007 Onglets à partir de colonne

micgca

XLDnaute Junior
Bonjour à tous,
j'ai une feuille avec des données comme
A1 = nr
A2 = Nom
A3= Prénom
ensuite on passe à
A8 = age
A9 = ville

et ma question est comment créer un onglet avec les données des colonnes B, un onglet avec les données de la colonne C etc de manière à avoir autant d'onglet que de colonnes.
Les noms d'onglet pourraient être nommés automatiquement avec le champ nr

Merci par avance pour le code.

PS : j'avais le code ci-dessous mais cela fonction lorsque les données sont en ligne et non en colonne

Sub test()

Dim i%, k%

Application.ScreenUpdating = False

With Sheets("Table")

'suppression des onglets existant deja

For k = Sheets.Count To 1 Step -1

If Left(Sheets(k).Name, 7) = "Dossier" Then

Application.DisplayAlerts = False

Sheets(k).Delete

Application.DisplayAlerts = True

End If

Next k

'boucle sur le nombre de dossier

For i = 2 To .Range("A65536").End(xlUp).Row

'création de l'onglet à partir de l'onglet vierge Formulaire

Sheets("Formulaire").Copy After:=Sheets(Sheets.Count)

ActiveSheet.Name = "Dossier_" & i - 1


.Range(.Cells(i, 1), .Cells(i, 9)).Copy

Sheets("Dossier_" & i - 1).Range("B2").PasteSpecial Paste:=xlValues, Transpose:=True

Next i

End With

Application.ScreenUpdating = True

End Sub
 

vgendron

XLDnaute Barbatruc
Hello
Pour parcourir les données selon les colonnes
LastCol= Cells(1, Columns.Count).End(xlToLeft).Column 'dernière colonne de la ligne 1
for i= 2 to LastCol
....
 

micgca

XLDnaute Junior
Bon,
pour être plus explicite, je joins un fichier.
On a une table Suivi que regroupe toutes les données.
On a un modèle de formulaire.

Ce que je cherche à faire : une macro qui va générer un nouvel onglet ou feuille qui aura comme nom le nr (ligne 2 de suivi)
et chaque nouvelle feuille reprendra les données par colonne de la feuille suivi.

Je galère un peu, même beaucoup.
Merci par avance.
 

Fichiers joints

vgendron

XLDnaute Barbatruc
Ca ne m'étonne pas que tu n'y arrives pas. ton code initial ne semble pas du tout correspondre à ton fichier..

essai en PJ
 

Fichiers joints

vgendron

XLDnaute Barbatruc
Bug.. car aucun controle pour savoir si la feuille existe déjà.. (si tu poses la question. c'est que tu as sans doute déjà la réponse... :-D

il faut donc ajouter un test
 

vgendron

XLDnaute Barbatruc
avec le test
VB:
Sub CréerOnglets()
Application.ScreenUpdating = False
Dim tablo() As Variant
With Sheets("Suivi")
    LastLine = .Range("A" & .Rows.Count).End(xlUp).Row 'on cherche la dernière ligne de la feuille
    LastCol = .UsedRange.Columns.Count 'on cherche la dernière colonne de la feuille
   
    tablo = .Range("A2").Resize(LastLine - 1, LastCol).Value 'on met toutes les data dans un tableau VBA
End With

For j = LBound(tablo, 2) + 1 To UBound(tablo, 2) 'pour chaque colonne
    If Not (FeuilleExiste("nr" & tablo(1, j))) Then
        Sheets("Formulaire").Copy after:=Sheets(Sheets.Count) 'on copie la feuille Formulaire
        Sheets("Formulaire (2)").Name = "nr" & tablo(1, j) 'qu'on renomme
        With Sheets("nr" & tablo(1, j)) 'dans cette nouvelle feuille
            For i = LBound(tablo, 1) To UBound(tablo, 1)
                .Range("B7").Offset(i - 1, 0) = tablo(i, j) 'on colle toutes les lignes
            Next i
        End With
    End If
Next j
Application.ScreenUpdating = True
End Sub


Function FeuilleExiste(NomFeuille As Variant) As Boolean
With ActiveWorkbook
    FeuilleExiste = False
    For Each ws In .Sheets
        If ws.Name = NomFeuille Then
            FeuilleExiste = True
            Exit For
        End If
    Next ws
End With
End Function
 

micgca

XLDnaute Junior
c'est ok, merci,
dernière chose, si je transpose tout cela dans un autre fichier, je ne sais pas pourquoi mais ça bug sur la ligne
With Sheets("nr" & tablo(1, j)) 'dans cette nouvelle feuille
 

micgca

XLDnaute Junior
non c'est bon c'est encore moi qui me trompait,
dernière chose, si je ne veux pas toutes les lignes mais les 12 premières uniquement ?

et si je veux les 12 premières ET les lignes 17 et 19 ?

juste le code après c'est promis je me débrouille
 

micgca

XLDnaute Junior
avec le test
VB:
Sub CréerOnglets()
Application.ScreenUpdating = False
Dim tablo() As Variant
With Sheets("Suivi")
    LastLine = .Range("A" & .Rows.Count).End(xlUp).Row 'on cherche la dernière ligne de la feuille
    LastCol = .UsedRange.Columns.Count 'on cherche la dernière colonne de la feuille
  
    tablo = .Range("A2").Resize(LastLine - 1, LastCol).Value 'on met toutes les data dans un tableau VBA
End With

For j = LBound(tablo, 2) + 1 To UBound(tablo, 2) 'pour chaque colonne
    If Not (FeuilleExiste("nr" & tablo(1, j))) Then
        Sheets("Formulaire").Copy after:=Sheets(Sheets.Count) 'on copie la feuille Formulaire
        Sheets("Formulaire (2)").Name = "nr" & tablo(1, j) 'qu'on renomme
        With Sheets("nr" & tablo(1, j)) 'dans cette nouvelle feuille
            For i = LBound(tablo, 1) To UBound(tablo, 1)
                .Range("B7").Offset(i - 1, 0) = tablo(i, j) 'on colle toutes les lignes
            Next i
        End With
    End If
Next j
Application.ScreenUpdating = True
End Sub


Function FeuilleExiste(NomFeuille As Variant) As Boolean
With ActiveWorkbook
    FeuilleExiste = False
    For Each ws In .Sheets
        If ws.Name = NomFeuille Then
            FeuilleExiste = True
            Exit For
        End If
    Next ws
End With
End Function
avec le test
VB:
Sub CréerOnglets()
Application.ScreenUpdating = False
Dim tablo() As Variant
With Sheets("Suivi")
    LastLine = .Range("A" & .Rows.Count).End(xlUp).Row 'on cherche la dernière ligne de la feuille
    LastCol = .UsedRange.Columns.Count 'on cherche la dernière colonne de la feuille
  
    tablo = .Range("A2").Resize(LastLine - 1, LastCol).Value 'on met toutes les data dans un tableau VBA
End With

For j = LBound(tablo, 2) + 1 To UBound(tablo, 2) 'pour chaque colonne
    If Not (FeuilleExiste("nr" & tablo(1, j))) Then
        Sheets("Formulaire").Copy after:=Sheets(Sheets.Count) 'on copie la feuille Formulaire
        Sheets("Formulaire (2)").Name = "nr" & tablo(1, j) 'qu'on renomme
        With Sheets("nr" & tablo(1, j)) 'dans cette nouvelle feuille
            For i = LBound(tablo, 1) To UBound(tablo, 1)
                .Range("B7").Offset(i - 1, 0) = tablo(i, j) 'on colle toutes les lignes
            Next i
        End With
    End If
Next j
Application.ScreenUpdating = True
End Sub


Function FeuilleExiste(NomFeuille As Variant) As Boolean
With ActiveWorkbook
    FeuilleExiste = False
    For Each ws In .Sheets
        If ws.Name = NomFeuille Then
            FeuilleExiste = True
            Exit For
        End If
    Next ws
End With
End Function
avec le test
VB:
Sub CréerOnglets()
Application.ScreenUpdating = False
Dim tablo() As Variant
With Sheets("Suivi")
    LastLine = .Range("A" & .Rows.Count).End(xlUp).Row 'on cherche la dernière ligne de la feuille
    LastCol = .UsedRange.Columns.Count 'on cherche la dernière colonne de la feuille
  
    tablo = .Range("A2").Resize(LastLine - 1, LastCol).Value 'on met toutes les data dans un tableau VBA
End With

For j = LBound(tablo, 2) + 1 To UBound(tablo, 2) 'pour chaque colonne
    If Not (FeuilleExiste("nr" & tablo(1, j))) Then
        Sheets("Formulaire").Copy after:=Sheets(Sheets.Count) 'on copie la feuille Formulaire
        Sheets("Formulaire (2)").Name = "nr" & tablo(1, j) 'qu'on renomme
        With Sheets("nr" & tablo(1, j)) 'dans cette nouvelle feuille
            For i = LBound(tablo, 1) To UBound(tablo, 1)
                .Range("B7").Offset(i - 1, 0) = tablo(i, j) 'on colle toutes les lignes
            Next i
        End With
    End If
Next j
Application.ScreenUpdating = True
End Sub


Function FeuilleExiste(NomFeuille As Variant) As Boolean
With ActiveWorkbook
    FeuilleExiste = False
    For Each ws In .Sheets
        If ws.Name = NomFeuille Then
            FeuilleExiste = True
            Exit For
        End If
    Next ws
End With
End Function
 

micgca

XLDnaute Junior
Bonjour à tous,
après avoir bien travailler sur le fichier, tout fonctionne bien, je recherche un code pour mettre à jour les onglets créés si on modifie le tableau général.
Merci par avance.
 

Haut Bas