copier coller avec plusieurs conditions

[seb83100]

Bonjour à tous,

Dans une feuille de calcul, je dois copier certaines informations et les coller sur une autre feuille mais le problème est que j'ai différentes conditions de "collage" des informations.

sur la feuille 1, j'ai préciser les conditions et sur la feuille 2 le résultat attendu.

ps: j'ai trouvé sur le forum comment copier coller une cellule avec des alt-entrée et je l'ai dupliquer pour deux colonnes.


vous trouverez en pièce jointe le fichier.

par avance merci de votre aide

 

[Paritec]

Re : copier coller avec plusieurs conditions

Bonjour seb 83100 le forum
Commence déjà par mettre autant de ligne que de produits et après on pourra traiter ton fichier, et t'aider.
Mettre 5 produits dans la même cellule!!!! ????? C'est nouveau??
a+
Papou

 

[seb83100]

Re : copier coller avec plusieurs conditions

bonsoir paritec,

malheureusement, les produits sont dans une seule cellule et je ne peux pas changer le format du fichier existant .

c'est pourquoi, j'ai cherché sur le forum comment séparer les données d'une cellule (macro du fichier).

merci de ton aide

 

[Paritec]

Re : copier coller avec plusieurs conditions

Re Seb 83100 le forum
c'est absolument impossible qu'un logiciel normalement constitué sortent des fichiers comme cela!!!!
en plus ton exemple est avec 1 2 3 4 5 mais la réalité c'est quoi???
et en plus c'est 12345 sans même un espace donc impossible à spliter!!!!
Tu ne me feras pas croire qu'un logiciel fait cela, là je suis sur que non!!!
a+
papou

 

[seb83100]

Re : copier coller avec plusieurs conditions

bonsoir paritec,
bonsoir le forum,

Effectivement, un logiciel ne peut pas sortir un tel fichier.

mon fichier joint n'est qu'un exemple.

Les données dans les colonnes produits et prix sont séparées par alt-entrée afin d'avoir une ligne pour chaque produits dans la cellule.
Comme tu peux le voir en cliquant sur le "bouton produits" ou "prix", la macro sépare les données en nombre de lignes correspondant au nombre de produits ou de prix.
Je joins de nouveau le classeur avec les macros pour séparer les données d'une même cellule.
Les données des colonnes produits et prix sont effacées dans la feuille 2 afin de tester le résultat de la macro.

merci pour votre aide.

 

[klin89]

Re : copier coller avec plusieurs conditions

Bonsoir seb83100, Paritec, le forum

A tester avec le fichier du post 1, résultat en feuil3 :

Option Explicit

Sub essai()
Dim a, b, i As Long, j As Long, x, y, n As Long, NbJours As Byte
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 4, 5, 7, 8, 9))
    End With
    ReDim b(1 To UBound(a, 1) * 100, 1 To UBound(a, 2) + 5)
    For i = 2 To UBound(a, 1)
        If (a(i, 4) <> "") * (a(i, 5) <> "") * (a(i, 6) <> "") Then
            x = Split(a(i, 4), vbLf)
            y = Split(a(i, 6), vbLf)
            NbJours = Day(DateSerial(a(i, 2), a(i, 3) + 1, 0))
            For j = 0 To Application.Min(UBound(x), UBound(y))
                n = n + 1
                b(n, 1) = a(i, 1)
                b(n, 4) = DateSerial(a(i, 2), a(i, 3), 1)
                b(n, 5) = DateSerial(a(i, 2), a(i, 3), NbJours)
                b(n, 6) = x(j)
                If j = 0 Then b(n, 8) = a(i, 5) Else b(n, 8) = ""
                b(n, 9) = Split(a(i, 6), vbLf)(j)
            Next
        End If
    Next
    With Sheets("Feuil3").Cells(1)
        .CurrentRegion.Clear
        .Resize(, 11).Value = [{"Ref Client","Typologie","Commentaire","Date début","Date fin","Produits","Activité","TVA","Prix","Type","Autres"}]
        .Offset(1).Resize(n, 11).Value = b
        With .CurrentRegion
            With .Rows(1)
                .Font.Bold = True
                .Font.Size = 12
                .Interior.ColorIndex = 43
                .BorderAround Weight:=xlThin
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Bonne nuit klin89

 

[seb83100]

Re : copier coller avec plusieurs conditions

bonjour klin89, paritec, le forum,

merci pour la macro cela fonctionne, reste plus qu'a l'adapter a mon "vrai" fichier.

bonne journée

 

[seb83100]

Re : copier coller avec plusieurs conditions

bonjour klin89, paritec, le forum,

merci pour la macro cela fonctionne, reste plus qu'a l'adapter a mon "vrai" fichier.

bonne journée

 

[klin89]

Re : copier coller avec plusieurs conditions

Re seb83100,

En bonus, la mise en forme du résultat en Feuil3 :

Sub MiseEnForme()
    Dim myArea As Range
    Application.ScreenUpdating = False
    With Sheets("Feuil3").Range("A1").CurrentRegion
        .Borders.LineStyle = xlNone
        .Columns(.Columns.Count + 1).EntireColumn.Insert
        With .Columns(.Columns.Count + 1)
            .Offset(1).Formula = _
            "=if(rc1<>r[-1]c1,if(r[-1]c=1,""a"",1),"""")"
            .Value = .Value
            On Error Resume Next
            .SpecialCells(2, 1).EntireRow.Insert
            .SpecialCells(2, 2).EntireRow.Insert
            On Error GoTo 0
            .EntireColumn.Delete
        End With
        For Each myArea In .Columns(1).SpecialCells(2).Areas
            myArea.CurrentRegion.Resize(, .Columns.Count).BorderAround Weight:=2
        Next
        .Columns(1).SpecialCells(4).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[klin89]

Re : copier coller avec plusieurs conditions

Re seb83100,

Quelques ajustements :

Sub essai2()
Dim a, b(), i As Long, j As Long, x, n As Long, NbJours As Byte, myArea As Range
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 4, 5, 7, 8, 9))
    End With
    ReDim b(1 To UBound(a, 1) * 100, 1 To UBound(a, 2) + 5)
    For i = 2 To UBound(a, 1)
        If (a(i, 4) <> "") * (a(i, 5) <> "") * (a(i, 6) <> "") Then
            x = Split(a(i, 4), vbLf)
            NbJours = Day(DateSerial(a(i, 2), a(i, 3) + 1, 0))
            For j = 0 To UBound(x)
                n = n + 1
                b(n, 1) = a(i, 1)
                b(n, 4) = DateSerial(a(i, 2), a(i, 3), 1)
                b(n, 5) = DateSerial(a(i, 2), a(i, 3), NbJours)
                b(n, 6) = x(j)
                If j = 0 Then b(n, 8) = a(i, 5)
                b(n, 9) = Split(a(i, 6), vbLf)(j)
            Next
        End If
    Next
    With Sheets("Feuil3").Cells(1)
        .CurrentRegion.Clear
        .Resize(, 11).Value = [{"Ref Client","Typologie","Commentaire","Date début","Date fin","Produits","Activité","TVA","Prix","Type","Autres"}]
        .Offset(1).Resize(n, 11).Value = b
        With .CurrentRegion
            .Columns(.Columns.Count + 1).EntireColumn.Insert
            With .Columns(.Columns.Count + 1)
                .Offset(1).Formula = _
                "=if(rc1<>r[-1]c1,if(r[-1]c=1,""a"",1),"""")"
                .Value = .Value
                On Error Resume Next
                .SpecialCells(2, 1).EntireRow.Insert
                .SpecialCells(2, 2).EntireRow.Insert
                On Error GoTo 0
                .EntireColumn.Delete
            End With
            For Each myArea In .Columns(1).SpecialCells(2).Areas
                myArea.CurrentRegion.Resize(, .Columns.Count).BorderAround Weight:=2
            Next
            .Columns(1).SpecialCells(4).EntireRow.Delete
            With .Rows(1)
                .Font.Bold = True
                .Font.Size = 12
                .Interior.ColorIndex = 40
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89