Eclater un tableau en onglets

Le 08/02/2019 à 16:30

Bonjour à tous,

J'ai besoin d'aide !

J'ai bien trouvé plusieurs sujets sur le net de nature à m'aider, plusieurs modèles, mais rien de parfaitement concluant.

Je cherche à (pas si simplement que ça) éclater un tableau en onglets.

Chaque onglet devra porter le nom de la cellule de la colonne A (colonne dont le titre est Chantier en "A1").

à partir de A2 jusqu'à Ax nous avons donc le nom du futur onglet, à savoir un nom de chantier.

Un lien hypertexte entre chaque cellule de l'onglet source (de A2 à Ax) serait un rêve !

La difficulté est que je vais avoir des suites (différentes en nombre de ligne) qui porteront le même titre et donc à concaténer dans le même onglet, en conservant la présentation...

Le reste du tableau (colonnes B etc...) sont des champs qu'il faut mettre dans les onglets, toujours en conservant la présentation.

Est-ce irréalisable ?

J'ai trouvé une macro qui fonctionnerait presque, mais de temps a autre, une feuille vide apparaît... ce qui gâche tout. ET il n'y a pas le fameux lien hypertexte...

Voici la macro :

Sub parse_data()

Dim lr As Long

Dim ws As Worksheet

Dim vcol, i As Integer

Dim icol As Long

Dim myarr As Variant

Dim title As String

Dim titlerow As Integer

vcol = 1

Set ws = Sheets("Rpt_BalanceAgee")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

title = "A1:C1"

titlerow = ws.Range(title).Cells(1).Row

icol = ws.Columns.Count

ws.Cells(1, icol) = "Unique"

For i = 2 To lr

On Error Resume Next

If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then

ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)

End If

Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))

ws.Columns(icol).Clear

For i = 2 To UBound(myarr)

ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then

Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""

Else

Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)

End If

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")

Sheets(myarr(i) & "").Columns.AutoFit

Next

ws.AutoFilterMode = False

ws.Activate

End Sub

Voici un exemple de ma page source, mais le vrai tableau varie en nombre de ligne, jusqu'à... + de 1000 lignes en PJ

Au secours Obewan, vous êtes notre dernier espoir...

Merci d'avance !

16balag-test.xlsx (17.69 Ko)
Le 08/02/2019 à 17:16

bonjour,

une proposition

Sub aargh()
    With Sheets("rpt_balanceagee")
    'supprime tous les onglets sauf rpt_balanceagee
        Application.DisplayAlerts = False
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                ws.Delete
            End If
        Next ws
        Application.DisplayAlerts = True
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        curval = ""
        fr = 2
        lr = 2
        For i = 2 To dl + 1
            If curval <> .Cells(i, 1) Then
                If curval <> "" Then
                    Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                    .Range("A1:L1").Copy ws.Cells(1, 1)
                    Range(.Cells(fr, 1), .Cells(lr, 12)).Copy ws.Cells(2, 1)
                    ws.Name = Left(curval, 31)
                End If
                fr = i
                lr = i
                curval = .Cells(i, 1)
            Else
                lr = lr + 1
            End If
        Next i
        .Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 11), order1:=xlAscending, Header:=xlYes
    End With
End Sub
Le 08/02/2019 à 17:50

Bonjour,

Bonjour h2so4,

Une autre proposition,

ALT F8, exécuter la procédure.

Cdlt.

47balag-test.xlsm (41.36 Ko)
Le 11/02/2019 à 10:22

Bonjour,

Merci de vos retours mais cela ne fonctionne pas.

L'idée est d'éclater la page Rpt_BalanceAgee en onglets, chaque nouvel onglet regroupant (conservant le détail) les lignes de même référence s de la colonne A.

La macro proposée le fait mais il apparaît des feuilles vides dans le lot.

Si en prime on peut inclure un lien hypertexte, c'est le paradis.

Pierre

Le 11/02/2019 à 10:28

Mes excuses !

Ca fonctionne pas si mal ! Même que ça fonctionne

Vous auriez une astuce pour ajouter une idée de macro pour automatiser des liens hyper textes ?

Merci infiniment

Pierre

Le 11/02/2019 à 12:43

Bonjour,

Une mise à jour à étudier.

Cdlt.

21balag-test.xlsm (46.93 Ko)
Le 11/02/2019 à 14:59

Merci encore.

Il reste un soucis, dans la macro suivante, toutes les lignes ne sont pas prises en compte, la macro s'arrête avant la fin du tableau.

Est-ce un problème de dimensions ?

Sub séparer()

With Sheets("rpt_balanceagee")

Application.DisplayAlerts = False

For Each ws In Worksheets

If ws.Name <> .Name Then

ws.Delete

End If

Next ws

Application.DisplayAlerts = True

dl = .Cells(Rows.Count, 1).End(xlUp).Row

.Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes

curval = ""

fr = 2

lr = 2

For i = 2 To dl + 1

If curval <> .Cells(i, 1) Then

If curval <> "" Then

Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))

.Range("A1:L1").Copy ws.Cells(1, 1)

Range(.Cells(fr, 1), .Cells(lr, 12)).Copy ws.Cells(2, 1)

ws.Name = Left(curval, 31)

End If

fr = i

lr = i

curval = .Cells(i, 1)

Else

lr = lr + 1

End If

Next i

.Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 11), order1:=xlAscending, Header:=xlYes

End With

End Sub

Pour l'essentiel ça fonctionne, mais donc pas jusqu'au bout sur un tableau long...

Merci Jean-Eric pour l'amélioration avec lien hyper texte, mais quand je remplace par d'autres données, le menu reste vide.

Pierre

Le 11/02/2019 à 15:08

bonjour,

ajout de l'hyperlien

Sub aargh()
    With Sheets("rpt_balanceagee")
        'supprime tous les onglets sauf rpt_balanceagee
        Application.DisplayAlerts = False
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                ws.Delete
            End If
        Next ws
        .Hyperlinks.Delete
        Application.DisplayAlerts = True
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        curval = ""
        fr = 2
        lr = 2
        For i = 2 To dl + 1
            If curval <> .Cells(i, 1) Then
                If curval <> "" Then
                    Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                    .Range("A1:L1").Copy ws.Cells(1, 1)
                    Range(.Cells(fr, 1), .Cells(lr, 12)).Copy ws.Cells(2, 1)
                    ws.Name = Left(curval, 31)
                End If
                fr = i
                lr = i
                curval = .Cells(i, 1)
            Else
                lr = lr + 1
            End If
        Next i
        .Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 11), order1:=xlAscending, Header:=xlYes
        For i = 2 To dl
                    .Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", SubAddress:="'" & Left(.Cells(i, 1), 31) & "'!A1"
        Next i
    End With
End Sub
Le 11/02/2019 à 15:28

Re,

Bonjour h2so4,

@ Pierre,

Quand tu poses une question, précise à qui tu t'adresses !...

Ensuite, peux-tu préciser :

Merci Jean-Eric pour l'amélioration avec lien hyper texte, mais quand je remplace par d'autres données, le menu reste vide.

Je ne comprends pas.

Les données sont issues du tableau croisé dynamique, à l'exécution de la procédure pour créer les feuilles.

Cdlt.

Le 12/02/2019 à 09:34

Bonjour docteurs,

A nouveau merci de vos efforts.

@ H2so4 :Mon principal soucis est que si la macro tourne bien (c'est ce que je veux ), elle s'arrête à la ligne 173 (après le chantier 1554103) et "bug" a priori sur le nom de la cellule/onglet... j'ai tenté de modifier les informations de la cellule en supprimant des caractères et autre, mais étrangement ça déplace le problème, en amont !

Autre chose, est-il obligatoire de commencer par supprimer les autres éventuels onglets ?

@ Jean-Eric, merci. Le soucis c'est que la mise en page (en passant par le croisé dynamique) disparaît completement, et l'avant dernière colonne avec ses couleurs est à conserver, car la première page principal est trier, découpé et imprimé in fine. Tu me diras, je peux parfaitement insérer une page à la fin des opérations...

Je ne suis pas un habitué des forums et je vous prie de m'excuser pour la forme imparfaite...

Et... je suis complètement béotion en vba... je copie, colle, bidouille... et implore de l'aide

Pierre

13balag-test.xlsx (90.43 Ko)
Le 12/02/2019 à 09:43

Bonjour,

Une question : Quelle est la règle pour les couleurs ?

Cdlt.

Le 12/02/2019 à 12:05

bonjour,

effectivement certains caractères ne passent pas dans le nom des onglets.

Sub aargh()
    With Sheets("source")
        'supprime tous les onglets sauf source
        Application.DisplayAlerts = False
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                ws.Delete
            End If
        Next ws
        'suppression de tous les hyperliens
        .Hyperlinks.Delete
        Application.DisplayAlerts = True
        'dl= dernière ligne de la source
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        'on trie le fichier sur colonne 1
        .Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        curval = "" ' valeur courante
        fr = 2 'première ligne à copier pour la valeur courante
        lr = 2 'dernière ligne à copier  pour la valeur courante
        For i = 2 To dl + 1 'on parcourt toutes les lignes +1
            If curval <> .Cells(i, 1) Then ' valeur ligne en cours <> valeur courante
                If curval <> "" Then ' si pas première ligne
                'ajout d'une feuille
                    Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                    'copie ligne entête
                    .Range("A1:L1").Copy ws.Cells(1, 1)
                    'copie lignes détails pour la valeur courante
                    Range(.Cells(fr, 1), .Cells(lr, 12)).Copy ws.Cells(2, 1)
                    ' nom de l'onglet
                    ws.Name = FormatNomOnglet(curval)
                End If
                fr = i 'premièreligne à copier pour la valeur courante
                lr = i 'dernière ligne à copier  pour la valeur courante
                curval = .Cells(i, 1) 'nouvelle valeur courante
            Else
                lr = lr + 1 ''dernière ligne à copier  pour la valeur courante
            End If
        Next i
        'on remet l'onglet source dans l'ordre initial
        .Cells(1, 1).Resize(dl, 12).Sort key1:=.Cells(1, 11), order1:=xlAscending, Header:=xlYes
        'on ajoute les hyperliens
        For i = 2 To dl
            .Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", SubAddress:="'" & FormatNomOnglet(.Cells(i, 1)) & "'!A1"
        Next i
    End With
End Sub

Function FormatNomOnglet(ByVal o)
'suppression des caractères non autorisés dans le nom d'un onglet et max 31caractères
    invcar = "?*[]&:/\" & Chr(10) & Chr(34)
    For i = 1 To Len(invcar)
        o = Replace(o, Mid(invcar, i, 1), "")
    Next i
    FormatNomOnglet = Left(o, 31)
End Function
Le 12/02/2019 à 12:09

@ Jean-Eric, je dois conserver la structure de présentation initiale, extraction d'un outils spécifique... pas changer les habitudes de mes chefs...

@h2so4, je teste ça de suite

En tout cas Messieurs, je suis bluffé par votre réactivité, votre bienveillance et votre efficacité !

Pierre

Le 12/02/2019 à 12:16

ALLELUIA !

MERCI !

C'est la macro ULTIME

Vous êtes formidables !

Vraiment au top !!

Le 12/02/2019 à 12:54

Re,

@ h2so4,

Clair, net et compréhensible par toutes et tous !...

Bonne journée.

Cdlt.

Rechercher des sujets similaires à "eclater tableau onglets"