Tirer tout ou partie d'en-têtes imbriqués en colonne

Le 23/10/2015 à 12:19

Bonjour à tous,

Je dispose de deux colonnes de données (colonne B et colonne C)

Sur ma colonne B, mes données ont des "titres" d'en-têtes qui se succèdent en cascade les uns sous les autres.

Je voudrais pouvoir aligner mes en-têtes en face de chaque donnée, pour avoir une donnée d'avantage "tablée".

Je vous mets un fichier explicite en pièce-jointe,

J'ai également pensé que la macro de Dan pouvait servir, j'essaye de voir ce que je peux en faire en attendant.

Sub test()
    'Macro dan
    Dim dlg As Integer, i As Integer, nblg As Integer
    Dim col As Byte, j As Byte
    Dim plage As Range
    Application.ScreenUpdating = False
    dlg = Range("A" & Rows.Count).End(xlUp).Row
    col = Range("A3").End(xlToRight).Column + 1
    Range("B3").EntireColumn.Insert

    i = 0

    Set plage = Range("A4:A" & dlg)
    nblg = plage.Rows.Count
    For j = 2 To col
        If j - 1 = 1 Then
            Do While i < nblg
                Range("b" & i + 4) = Cells(3, j + 1)
                i = i + 1
            Loop
        Else:
            i = Range("B" & Rows.Count).End(xlUp).Row + 1
            Do While i <= dlg
                Range("b" & i) = Cells(3, j + 1)
                i = i + 1
            Loop
        End If
        If j <> col And j + 1 <> col Then
            plage.Copy Range("A" & dlg + 1)
            plage.Offset(0, j + 1).Cut Range("A" & dlg + 1).Offset(0, 2)
            dlg = Range("A" & Rows.Count).End(xlUp).Row
        End If
        Cells(3, j + 1).ClearContents

    Next
    Application.ScreenUpdating = True
    End Sub

Merci beaucoup par avance,

G.

16exemple.xlsx (10.93 Ko)
Le 23/10/2015 à 22:32

Bonjour, sinon avec ceci c'est possible mais il faut retravailler quelques éléments. C'est du "bidouillage maison" (donc le contraire d'une macro "pro" faites par un pro...) qui peut peut-être vous amener sur une bonne piste...

Sub test()
  For i = 1 To Feuil1.UsedRange.Rows.Count
    With Feuil1
      If .Cells(i, 3) = "" Then
        .Cells(i, 2).Copy .Cells(i, 5).Offset(1, 0)
        .Cells(i, 5).Offset(1, 0).AutoFill Range(.Cells(i, 5).Offset(1, 0), Cells(Feuil1.UsedRange.Rows.Count, 5)), xlFillCopy
      End If
    End With
  Next
  With Feuil1
    .[b:c].Copy .[f:g]
    For i = 1 To .UsedRange.Rows.Count
      If .Cells(i, 7) = "" Then
        Range(.Cells(i, 5), .Cells(i, 7)).Delete shift:=xlUp
      End If
    Next
  End With

End Sub
7exemple.xlsm (18.59 Ko)
Le 23/10/2015 à 22:51

Trop tard...

je donne ma réponse comme même !

10loureed-exemple.xlsm (17.79 Ko)

@ bientôt

LouReeD

Le code expliqué...

en fait pour faire simple, je rajoute le mot fin en fin de colonne 2

ensuite c'est une boucle indéfinie jusqu'à ce mot fin.

Evidemment pour être plus Pro il suffit de faire une recherche de dernière ligne, mais tout dépend de la structure de votre feuille, autant il existe des données en dessous qui ne font pas partie du tableau à décomposer....

Sub décompose()

    Application.ScreenUpdating = False

    Dim Ligne_Nom As Long ' ligne de recherche dans la colonne des attributs
    Dim Ligne_Résultat ' ligne d'inscription de la décomposition
    Dim L_attribut As String ' nom de l'attribut en cours

    Ligne_Nom = 2 ' le tableau de recherche commence en ligne 2
    Ligne_Résultat = 3 ' numéro de ligne du premier résultat
    L_attribut = "" ' l'attribut en cours est égal à rien

    Do ' début d'une boucle indéfinie
        If Cells(Ligne_Nom, 2) = "fin" Then Exit Do ' si on arrive à fin alors on sort de la boucle
        If Cells(Ligne_Nom, 3) = "" Then ' si la cellule de la colonne 3 est vide en colonne 2 on a l'attribut
            L_attribut = Cells(Ligne_Nom, 2).Value ' on le met en mémoire
        Else ' si la cellule en colonne 3 est pleine
            Cells(Ligne_Résultat, 13).Value = L_attribut ' sur le tableau résultat on marque l'attribut en mémoire
            Cells(Ligne_Résultat, 14).Value = Cells(Ligne_Nom, 2).Value ' nom de l'attribut
            Cells(Ligne_Résultat, 15).Value = Cells(Ligne_Nom, 3).Value ' valeur de l'attribut
            Ligne_Résultat = Ligne_Résultat + 1 ' on passe à la ligne de résultat suivante
        End If
        Ligne_Nom = Ligne_Nom + 1 ' on poursuit le scan du tableau de recherche en passant à la ligne suivante
    Loop

    Cells(2, 14).Value = Ligne_Résultat - 3 ' on inscrit le nombre de valeur dans la cellule en haut du tableau résultat

    Application.ScreenUpdating = True

End Sub

@ bientôt

LouReeD

Le 23/10/2015 à 23:00

Non pas trop tard...Si votre macro est passepartout elle est plus adaptée que la mienne qui est plus du rafistolage de maraicher

Le 23/10/2015 à 23:12

J'espère que vous avez autant le sourire que votre cornichon

Après Sébastien et ses avatars dont je suis utilisateur, vous voici (nous voici) dans un but de culture de légumes !? oui aux maraichers !!! A nous, à vous, à nous tous les avatars "fruits et légumes" !!!

@ bientôt

LouReeD

Le 24/10/2015 à 09:30

C'est vous qui avez commencé avec votre livre donc assumez !!

Le 24/10/2015 à 13:42

Ok d'ac !!!

je change !!!

@ bientôt

LouReeD

Le 24/10/2015 à 14:40

Bonjour,

Une nouvelle proposition à étudier. pour le fun.

10exemple.xlsm (20.97 Ko)
Private Sub cmdNormaliser_Click()
Dim lrow As Long, i As Long
Dim str As String

    Application.ScreenUpdating = False

    With ActiveSheet
        lrow = 3
        .Cells(2, "M").CurrentRegion.Offset(1, 0).ClearContents
        For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
            Select Case .Cells(i, "C")
                Case vbNullString
                    str = Split(.Cells(i, "B"))(1)
                Case Else
                    .Cells(lrow, "M") = str
                    .Range(.Cells(lrow, "N"), .Cells(lrow, "O")).Value = _
                        .Range(.Cells(i, "B"), .Cells(i, "C")).Value
                    lrow = lrow + 1
            End Select
        Next
    End With

End Sub
Le 24/10/2015 à 19:11

Bonjour à tous,

Une autre version :

Option Explicit

Sub test()
Dim myAreas As Areas, myArea As Range, i As Long, n As Long, x As Long, b()
    'attention à la dimension
    ReDim b(1 To 1000, 1 To 3)
    With Sheets("Feuil1")
        With .Range("c1", .Range("c" & Rows.Count).End(xlUp))
            On Error Resume Next
            Set myAreas = .SpecialCells(2, 1).Areas
            On Error GoTo 0
            If myAreas Is Nothing Then Exit Sub
            For Each myArea In myAreas
                x = x + 1
                For i = 1 To myArea.Rows.Count
                    n = n + 1
                    b(n, 1) = x
                    b(n, 2) = myArea.Offset(, -1).Cells(i).Value
                    b(n, 3) = myArea.Cells(i).Value
                Next
            Next
            Set myAreas = Nothing
            With .Offset(, .Columns.Count + 1).Resize(n, UBound(b, 2))
                .CurrentRegion.Cells.Clear
                .Value = b
                .Columns.ColumnWidth = 17
            End With
        End With
    End With
End Sub

Ou celle-ci :

Option Explicit

Sub test()
Dim myAreas As Areas, myArea As Range, i As Long, n As Long, b()
    'attention à la dimension
    ReDim b(1 To 1000, 1 To 3)
    With Sheets("Feuil1")
        With .Range("c1", .Range("c" & Rows.Count).End(xlUp))
            On Error Resume Next
            Set myAreas = .SpecialCells(2, 1).Areas
            On Error GoTo 0
            If myAreas Is Nothing Then Exit Sub
            For Each myArea In myAreas
                For i = 1 To myArea.Rows.Count
                    n = n + 1
                    b(n, 1) = myArea.Cells(1)(0, 0)
                    b(n, 2) = myArea.Cells(i)(1, 0)
                    b(n, 3) = myArea.Cells(i)
                Next
            Next
            Set myAreas = Nothing
            With .Offset(, .Columns.Count + 1).Resize(n, UBound(b, 2))
                .CurrentRegion.Cells.Clear
                .Value = b
                .Columns.ColumnWidth = 17
            End With
        End With
    End With
End Sub

klin89

Le 24/10/2015 à 21:37

Re Pwetzou

Avec la méthode PasteSpecial :

Sub test()
Dim myAreas As Areas, myArea As Range, n As Long, x As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil1")
        .Cells(1, 5).CurrentRegion.Clear
        Set myAreas = .Columns(3).SpecialCells(2, 1).Areas
        n = 1
        For Each myArea In myAreas
            x = x + 1
            .Cells(n, 5).Resize(myArea.Rows.Count).Value = x
            myArea.Offset(, -1).Resize(, 2).Copy
            .Cells(n, 6).PasteSpecial Transpose:=False
            n = n + myArea.Rows.Count
        Next
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

klin89

Le 25/10/2015 à 07:41

Bonjour,

c'est ce que je disais... tout dépend de la structure de la feuille... si des données sont inscrites sous le tableau il y a erreur avec Rows.Count d'où le déplacement de la formule BNVAL...

Il est vrai aussi que les données étant écrites l'une à coté des autres le découpage :

           Cells(Ligne_Résultat, 14).Value = Cells(Ligne_Nom, 2).Value ' nom de l'attribut
            Cells(Ligne_Résultat, 15).Value = Cells(Ligne_Nom, 3).Value ' valeur de l'attribut

n'est pas nécessaire comme dans l'exemple d'Eriiiic, où un range première cellule à deuxième cellule "économise" une ligne de code.

Allez, faites votre choix et cet exemple montre que tous les chemins mènent à Rome !!!

@ bientôt

LouReeD

Le 26/10/2015 à 13:30

ha bah ça en fait des possibilités !

Merci pour tous vos retours, je vais digérer ça en conséquence.

J'en apprends tous les jours ici, entre CodeCademy, Openclassroom et les Mooc...

G.

Rechercher des sujets similaires à "tirer tout partie tetes imbriques colonne"