Fractionner plusieurs colonnes sur plusieurs lignes

Bonjour,

j'ai ici un problème insoluble (du moins pour moi) et je pense qu'on ne peut le résoudre que par VBA.

Je suis novice dans ce langage mais je suis disposé à me perfectionner si besoin est.

Tout est clairement expliqué dans le fichier joint, et je crois que c'est plus facile ainsi pour tout le monde...

Bien entendu un grand merci à qui saura résoudre ce problème !

Bonne année 2020 à tous et à toutes en passant !

Fanf

Bonjour

Ci joint une proposition

Fred

Bonjour

Ci joint une proposition

Fred

Bonjour Fred,

d'abord merci pour la rapide réponse.... j'étais sidéré du résultat et de la simplicité du code (que j'avoue n'avoir rien compris encore).

Cependant un bémol : si je remplace "medor" par un champ vide, la ligne n'est pas créée.

Et surtout si je remplace "wouf" ou "4" par un champ vide, un message d'erreur fait planter le code...

Pouvez-vous y remédier ? :-O

D'avance merci pour votre implication ! J'apprécie

Fanf

Bonsoir j essai de faire cela demain.

Fred

Salut Fanfoue,

Salut Fred,

en échappant aux chausses-trappes grâce à l'abnégation de Fred

Un double-clic démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, iNb%, sItem$
'
Cancel = True
Application.ScreenUpdating = False
'
Range("B9:F20").Delete shift:=xlUp
For x = 6 To 8
    iNb = 0
    For y = 3 To 6
        iNb = IIf(UBound(Split(Cells(x, y), "\")) > iNb, UBound(Split(Cells(x, y), "\")), iNb)
    Next
    For y = 0 To iNb
        iRow = Range("B" & Rows.Count).End(xlUp).Row + 1
        Cells(iRow, 2) = Cells(x, 2)
        For Z = 3 To 6
            If InStr(Cells(x, Z), "\") = 0 Then
                sItem = Cells(x, Z)
            Else
                If y <= UBound(Split(Cells(x, Z), "\")) Then
                    sItem = Split(Cells(x, Z), "\")(y)
                Else
                    sItem = ""
                End If
            End If
            Cells(iRow, Z) = sItem
        Next
    Next
Next
'
Application.ScreenUpdating = True
'
End Sub

A+

4fanfoue.xlsm (17.46 Ko)

Salut Fanfoue,

Salut Fred,

en échappant aux chausses-trappes grâce à l'abnégation de Fred

Un double-clic démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, iNb%, sItem$
'
Cancel = True
Application.ScreenUpdating = False
'
Range("B9:F20").Delete shift:=xlUp
For x = 6 To 8
    iNb = 0
    For y = 3 To 6
        iNb = IIf(UBound(Split(Cells(x, y), "\")) > iNb, UBound(Split(Cells(x, y), "\")), iNb)
    Next
    For y = 0 To iNb
        iRow = Range("B" & Rows.Count).End(xlUp).Row + 1
        Cells(iRow, 2) = Cells(x, 2)
        For Z = 3 To 6
            If InStr(Cells(x, Z), "\") = 0 Then
                sItem = Cells(x, Z)
            Else
                If y <= UBound(Split(Cells(x, Z), "\")) Then
                    sItem = Split(Cells(x, Z), "\")(y)
                Else
                    sItem = ""
                End If
            End If
            Cells(iRow, Z) = sItem
        Next
    Next
Next
'
Application.ScreenUpdating = True
'
End Sub

A+

Bonjour Curilis,

Bonjour Fred,

je ne peux que m'incliner, tant votre savoir-faire est précieux et remarquable.... Et c'est un informaticien de 50 piges qui parle là !

Ceci dit je viens de passer une bonne heure à étudier votre code Curulis et je vais essayer de l'appliquer à mon tableau de données effectif (qui est un brin plus compliqué avec 90 colonnes à traiter...). Je dois juste piger comment vous avez fait pour recopier la première cellule en colonne 2 (car dans votre code les boucles FOR vont de la colonne 3 à 6 et non pas de 2 à 6)...

Je vous poste une ligne exemple de mon fichier excel final au cas où cela vous tenterait de voir à quoi me servirait tout cela au final une fois que j'aurais réussi à adapter votre code.

Bien à vous,

Fanfoué

Salut Fanfoue,

Salut Fred,

Code adapté! Toujours un double-clic en feuille 'BDD' pour démarrer la macro, résultats en 'Extract'.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, tExtract(), iIdx%, iNb%, sItem$
'
Cancel = True
Application.ScreenUpdating = False
'
tTab = Range("A1").Resize(Range("A" & Rows.Count).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column).Value
For x = 1 To UBound(tTab, 1)
    iNb = 0
    For y = 1 To UBound(tTab, 2)
        iNb = IIf(UBound(Split(tTab(x, y), "\")) > iNb, UBound(Split(tTab(x, y), "\")), iNb)
    Next
    For y = 0 To iNb
        iIdx = iIdx + 1
        ReDim Preserve tExtract(UBound(tTab, 2), iIdx)
        For Z = 1 To UBound(tTab, 2)
            If InStr(tTab(x, Z), "\") = 0 Then
                sItem = tTab(x, Z)
            Else
                If y <= UBound(Split(tTab(x, Z), "\")) Then
                    sItem = Split(tTab(x, Z), "\")(y)
                Else
                    sItem = ""
                End If
            End If
            tExtract(Z - 1, iIdx - 1) = sItem
        Next
    Next
Next
With Worksheets("Extract")
    .Cells.Delete
    .Range("A1").Resize(iIdx, UBound(tTab, 2)).Value = WorksheetFunction.Transpose(tExtract)
    .UsedRange.Borders.LineStyle = xlContinuous
    .Columns.AutoFit
    .Activate
End With
'
Application.ScreenUpdating = True
'
End Sub

A+

11fanfouebis.xlsm (18.61 Ko)

Salut Fanfoue,

Salut Fred,

Code adapté! Toujours un double-clic en feuille 'BDD' pour démarrer la macro, résultats en 'Extract'.

A+

Impressionnant... Je crois que j'aurais pu y passer des jours pour essayer de l'adapter... Que dire ?... Sujet résolu... Et bien au-delà de mes espérances... Savez-vous que vous m'avez donné un fier coup de pouce dans l'avancée de mes travaux, Curilis ? Sans oublier Fred aussi ! Bravo, tout simplement !.... Si vous passez dans la région autour de Chamonix, surtout n'hésitez pas à me contacter pour un gueuleton bien arrosé, si si si j'insiste !!!

Excellente fin de semaine à vous en attendant !

Fanfoué

Bonjour à tous... ayant été malade une partie de la journée d'hier et cette nuit... (c'est pour cela que j'avais une réponse rapide en disant que je "traiterais demain")

ci joint une autre proposition sur le problème des cellules vides et j'ai aussi commenté le code....

si le problème est résolu n'oubli pas :

Fred

Bonjour à tous... ayant été malade une partie de la journée d'hier et cette nuit... (c'est pour cela que j'avais une réponse rapide en disant que je "traiterais demain")

ci joint une autre proposition sur le problème des cellules vides et j'ai aussi commenté le code....

si le problème est résolu n'oubli pas :

Fred

Bonjour Fred,

un grand merci à toi aussi qui m'a bien donné espoir quand à la résolution de mon problème. Nul doute que je vais approfondir mes connaissances VBA et j'apprécie tes commentaires du code qui aident la compréhension !

En te souhaitant un prompt et complet rétablissement surtout !

Fanfoué

Merci

Fred

Rechercher des sujets similaires à "fractionner colonnes lignes"