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
 

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.
 

Pièces jointes

  • essaimoi.xlsx
    8.8 KB · Affichages: 21

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
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
 

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 796
Membres
101 817
dernier inscrit
carvajal