Eclater une ligne sur plusieurs ligne

Bonjour à tous,

Je bidouille depuis quelques années sur excel, et cherche avec plaisir à élucider mes petits casse-tête, mais là...

Il me semble qu'il est nécessaire de passer par VBA

Et le problème est que je ne sais pas utiliser VBA...

Voici ce que je voudrai faire:

En partant de cette Feuil1

capture

Copier rang (A2;F2), Coller en Feuil2 rang (A2;F2)

passer à la ligne

Copier Cell G2, Coller en Feuil2 Cell A3

Copier Cell H2, Coller en Feuil2 Cell C3

Copier rang (I2;L2), Coller en Feuil2 rang (G3;J3)

if K2= "FOR_ARR_*" then passer à la ligne et coller K2 en feuil2 A4

Else

if M2 <>"" then Coller à la ligne en colonne A

Else

If N2<>"" then Coller à la ligne en colonne A

Else

If O2<>"" then Coller à la ligne en colonne A

Arrivé en colonne P, sauter une ligne et recommencer en feuil1 ligne 3

Pour en arriver à:

Feuil2

capture2

Je ne suis pas sûr d'être clair, je ne sais pas si c'est réalisable, je ne sais pas si c'est compliqué...mais j'espère qu'un amateur de casse-tête pourra m'aider.

Merci d'avance pour vos retours.

9modele.xlsx (9.68 Ko)

Salut SoGro,

pas un casse-tête... mais vérifie quand même : je suis parfois si distrait!

Un double-clic en 'BDD' démarre la macro...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iRow%
'
Cancel = True
Application.ScreenUpdating = False
'
With Worksheets("EXTRACT")
    .Cells.Delete
    For x = 2 To Range("A" & Rows.Count).End(xlUp).Row
        iRow = iRow + IIf(iRow = 0, 1, 2)
        .Range("A" & iRow & ":F" & iRow).Value = Range("A" & x & ":F" & x).Value
        iRow = iRow + 1
        .Cells(iRow, 1) = Cells(x, 7)
        .Cells(iRow, 3) = Cells(x, 8)
        .Range("G" & iRow & ":J" & iRow).Value = Range("I" & x & ":L" & x).Value
        If Cells(x, 11) = "FOR_ARR_*" Then
            iRow = iRow + 1
            .Cells(iRow, 1) = Cells(x, 11)
        End If
        For y = 1 To 3
            If Cells(x, 12 + y) <> "" Then
                iRow = iRow + 1
                .Cells(iRow, 1) = Cells(x, 12 + y)
            End If
        Next
    Next
    .Activate
End With
'
Application.ScreenUpdating = True
'
End Sub

A+

8modele.xlsm (17.54 Ko)

Bonjour Curulis,

Merci pour ta réponse, et ta solution qui fonctionne à merveille!

J'essaierai de trouver quelque chose de plus complexe pour la prochaine fois!

Je suis ravi de voir que j'ai compris certaines choses dans ce code, et j'y ai apporté quelques modifications

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iRow%
'
Cancel = True
Application.ScreenUpdating = False
'
With Worksheets("EXTRACT")
    .Cells.Delete
    For x = 2 To Range("A" & Rows.Count).End(xlUp).Row
        iRow = iRow + IIf(iRow = 0, 1, 2)
        .Range("A" & iRow & ":F" & iRow).Value = Range("A" & x & ":F" & x).Value
        iRow = iRow + 1
        .Cells(iRow, 1) = Cells(x, 7)
        .Cells(iRow, 3) = Cells(x, 8)
        .Range("G" & iRow & ":H" & iRow).Value = Range("I" & x & ":J" & x).Value
        .Cells(iRow, 10) = Cells(x, 12)
        If Cells(x, 11) = "FOR_ARR_STR" Or Cells(x, 11) = "FOR_ARR_PVC" Then
            iRow = iRow + 1
            .Cells(iRow, 1) = Cells(x, 11)
            .Cells(iRow, 9).Value = "H"
            .Cells(iRow, 3) = Cells(x, 8)
        Else: .Cells(iRow, 9) = Cells(x, 11)
        End If
        For y = 1 To 3
            If Cells(x, 12 + y) <> "" Then
                iRow = iRow + 1
                .Cells(iRow, 1) = Cells(x, 12 + y)
            End If
        Next
    Next
    .Activate
End With
'
Application.ScreenUpdating = True
'
End Sub

Bon... de là a écrire la macro tout seul...mais c'est un premier pas qui donne envie de faire le second!

Encore un grand merci!

Rechercher des sujets similaires à "eclater ligne"