XL 2010 [Résolu] Copier/Coller ligne avec conditions et récurrences

[Saxophone]

Bonjour à toutes et tous
Je n'ai pas trouvé de solution sur le forum répondant spécifiquement à un cas comme celui-ci...
Je vous explique la situation :
La colonne A contient un numéro de demande.
Pour chaque numéro de demande, les colonnes B, C et D de la même ligne peuvent contenir des données si l'utilisateur les a remplies.

On a donc par exemple 2 numéros de demande "1" et "2" et des données inscrites par l'utilisateur

A B C D
1 x y z
2 u v

Et dans un autre onglet je souhaiterai que la macro qui s'exécute donne :

A B C D
1 x
1 y
1 z
2 u
2 v

Je le traduirai comme ceci à l'écrit :
Pour chaque numéro de commande de la colonne A :
Si le contenu de la cellule B2 <> "" alors on copie dans l'autre onglet le contenu de A2 et B2
Si le contenu de la cellule C2 <> "" alors on copie dans l'autre onglet le contenu de A2 et C2
Si le contenu de la cellule D2 <> "" alors on copie dans l'autre onglet le contenu de A2 et D2

Je ne vois pas comment gérer la chose en VBA, étant pas bon pour créer des codes et je n'ai rien trouvé correspondant à ça sur internet ou bien je n'ai pas su l'adapter.

Merci beaucoup de votre aide.

 

[Staple1600]

Re à tous

Voici de quoi t'ôter l'épine alors

Sub DernierTestOK()
Dim L&, i&, Q&, ZZ&
L = Range("B" & Rows.Count).End(xlUp).Row
For i = 7 To L
Q = Feuil4.Cells(Rows.Count, 1).End(xlUp).Row
ZZ = Application.CountA(Cells(i, "M"), Cells(i, "O"), Cells(i, "Q"))
Feuil4.Range("F:F,H:H").NumberFormat = "m/d/yyyy"
Feuil4.Range("G:G,I:I").NumberFormat = "h:mm"
Feuil4.Cells(Q + 1, 1).Resize(ZZ).Value = Cells(i, 2).Value
Feuil4.Cells(Q + 1, 4).Resize(ZZ).Value = Application.Transpose(Array(Cells(i, "M").Text, Cells(i, "O").Text, Cells(i, "Q").Text))
Feuil4.Cells(Q + 1, 6).Resize(ZZ).Value = Cells(i, 5).Value
Feuil4.Cells(Q + 1, 7).Resize(ZZ).Value = Cells(i, 6).Value
Feuil4.Cells(Q + 1, 8).Resize(ZZ).Value = Cells(i, 7).Value
Feuil4.Cells(Q + 1, 9).Resize(ZZ).Value = Cells(i, 8).Value
Q = Q + 1
Next
End Sub

 

[Saxophone]

Re Staple,

Merci, le "bug" que j'avais sur la demande n°3 n'existe plus.
Concernant l'épine, elle y est toujours :'( certes dans l'onglet résultat les heures apparaissent de la bonne manière, le problème c'est à l'export en .csv (j'ai ajouté le module au fichier joint). Elles se transforment en décimale. Peut-on appliquer un format texte à ces colonnes en ajoutant un " ' " devant chaque cellule ou je ne sais comment afin que la valeur des heures à l'export reste au format "hh:mm" ?

=TEXTE(cellule;"hh:mm")

Je sais que cette formule permet de récupérer au format texte et que ça ne bouge pas, malheureusement je ne vois pas comment l'inclure dans la macro pour que la transformation se passe en toute transparence...
Autrement il faudrait ajouter une colonne, appliquer la formule, copier coller les valeurs et ensuite supprimer la colonne transitoire pour obtenir le résultat. Malheureusement comment savoir sur quelle longueur étirer cette formule ? (je l'aurai bien fais via l'enregistreur de macro mais la longueur non prévisible...)

 

[Staple1600]

Re à tous

Avec un export CSV basique
(Tesk OK sur le fichier exemple)
Quand on réouvre le CSV dans Excel, les formats sont conservés.

Sub DernierTestV2()
Dim L&, i&, Q&, ZZ&
L = Range("B" & Rows.Count).End(xlUp).Row
For i = 7 To L
Q = Feuil4.Cells(Rows.Count, 1).End(xlUp).Row
ZZ = Application.CountA(Cells(i, "M"), Cells(i, "O"), Cells(i, "Q"))
Feuil4.Range("C:C,E:E").NumberFormat = "m/d/yyyy"
Feuil4.Range("D:D,F:F").NumberFormat = "h:mm"
Feuil4.Cells(Q + 1, 1).Resize(ZZ).Value = Cells(i, 2).Value
Feuil4.Cells(Q + 1, 2).Resize(ZZ).Value = Application.Transpose(Array(Cells(i, "M").Text, Cells(i, "O").Text, Cells(i, "Q").Text))
Feuil4.Cells(Q + 1, 3).Resize(ZZ).Value = Cells(i, 5).Value
Feuil4.Cells(Q + 1, 4).Resize(ZZ).Value = Cells(i, 6).Value
Feuil4.Cells(Q + 1, 5).Resize(ZZ).Value = Cells(i, 7).Value
Feuil4.Cells(Q + 1, 6).Resize(ZZ).Value = Cells(i, 8).Value
Q = Q + 1
Next
Feuil4.Copy
'remplacer C:\Tempo\ par le nom du dossier réel
ActiveWorkbook.SaveAs Filename:="C:\Tempo\test.csv", FileFormat:=xlCSV, Local:=True
ActiveWorkbook.Close False
End Sub

 

[Modeste]

Bonsoir,

Le problème c'est que lors de l'extraction en .csv, les données seront en décimales pour les heures (les dates ça fonctionne je ne sais pas trop pourquoi), or j'aimerai qu'elles restent en tant que ;hh:mm;

Je ne suis pas un utilisateur régulier des fichiers .csv, mais avec un Enregistrer sous (comme proposé par notre agrafe ) les formats heure semblent préservés (même si on applique les formats au départ, comme proposé plus haut). Quel est l'avantage du module que tu as ajouté, par rapport au Save As ?
Si tu convertissais tes données en texte, pour conserver le format, es-tu certain que tu n'aurais pas de souci par la suite, au moment d'exploiter les données de ton .csv ?
Bref, tout ceci nous a un tantinet éloignés de la demande de départ ... et je ne pourrai pas être d'un grand secours, au-delà de ce que j'ai proposé.

Je te laisse -à mon tour- en compagnie de Staple1600 (et d'Eileen, puisqu'il y tient )

 

[Staple1600]

Re à tous

Salut Modeste
Chui plus là, je suis parti voir le film sur France 2
Je passe donc d'Eileen à Jessica

Et Saxo se retrouve sans Piccolo, donc tout seul.

 

[Saxophone]

Re
Ton code fonctionne PAR-FAI-TE-MENT Staple ! Seulement je n'ai pas repris ton dernier code, juste celui d'avant et j'ai pris la partie création .csv.
T'es un chef.
Un grand merci à Modeste aussi.
Je sais pas trop comment vous remercier !!! Je suis tout fou en voyant enfin le graal !!!
Merci ! Bon film ^^

Sub DernierTestOK()
Dim L&, i&, Q&, ZZ&
L = Range("B" & Rows.Count).End(xlUp).Row
For i = 7 To L
Q = Feuil4.Cells(Rows.Count, 1).End(xlUp).Row
ZZ = Application.CountA(Cells(i, "M"), Cells(i, "O"), Cells(i, "Q"))
Feuil4.Range("E:E,G:G").NumberFormat = "m/d/yyyy"
Feuil4.Range("F:F,H:H").NumberFormat = "h:mm"
Feuil4.Cells(Q + 1, 1).Resize(ZZ).Value = Cells(i, 2).Value
Feuil4.Cells(Q + 1, 4).Resize(ZZ).Value = Application.Transpose(Array(Cells(i, "M").Text, Cells(i, "O").Text, Cells(i, "Q").Text))
Feuil4.Cells(Q + 1, 5).Resize(ZZ).Value = Cells(i, 5).Value
Feuil4.Cells(Q + 1, 6).Resize(ZZ).Value = Cells(i, 6).Value
Feuil4.Cells(Q + 1, 7).Resize(ZZ).Value = Cells(i, 7).Value
Feuil4.Cells(Q + 1, 8).Resize(ZZ).Value = Cells(i, 8).Value
Q = Q + 1
Next
Feuil4.Copy
'remplacer C:\Tempo\ par le nom du dossier réel
ActiveWorkbook.SaveAs Filename:="C:\Users\Maxime\Desktop\ONYCROIT\test.csv", FileFormat:=xlCSV, Local:=True
ActiveWorkbook.Close False
End Sub

 

[klin89]

Salut à tous,

Un poil similaire à modeste mais sans ReDim Preserve
Avec le fichier du post #36

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long
    With Feuil1.Range("b6").CurrentRegion
        a = .Value
    End With
    ReDim b(1 To ((UBound(a, 2) - 11) * (UBound(a, 1) - 1)), 1 To 8)
    n = 1
    b(n, 1) = a(1, 1): b(n, 2) = a(1, 2)
    b(n, 3) = a(1, 3): b(n, 4) = "Data User"
    b(n, 5) = a(1, 4): b(n, 6) = a(1, 5)
    b(n, 7) = a(1, 6): b(n, 8) = a(1, 7)
    For i = 2 To UBound(a, 1)
        For j = 12 To UBound(a, 2) Step 2
            If Not IsEmpty(a(i, j)) Then
                n = n + 1
                b(n, 1) = a(i, 1): b(n, 4) = a(i, j)
                b(n, 5) = a(i, 4): b(n, 6) = a(i, 5)
                b(n, 7) = a(i, 6): b(n, 8) = a(i, 7)
            End If
        Next
    Next
    'Restitution
    With Feuil4.Cells(1)
        .CurrentRegion.Clear
        With .Resize(n, 8)
            .FormulaLocal = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .Interior.ColorIndex = 36
                .Font.Size = 11
            End With
            .Columns(6).NumberFormat = "h:mm"
            .Columns(8).NumberFormat = "h:mm"
            .Columns.ColumnWidth = 12
            .Parent.Activate
        End With
    End With
End Sub

klin89

 

[Modeste]

Salut le fil,
Salut klin89

Un poil similaire à modeste

Et comment donc un poil pourrait-il m'être similaire

... Une bien bonne nuit à toutes et tous!

 

[Saxophone]

Bonjour à tous !
Je ne me doutais pas de ce cas de figure :
Si dans l'onglet "Feuil1", dans les colonnes "User Data 1, 2 ou 3", il n'y a pas de donnée visible mais une formule avec condition, dans la "Feuil2" on a une cellule vide (ça devait être ça mon "bug" de l'autre fois Staple1600, seulement je ne savais pas l'expliquer avant de bien pratiquer le fichier).
FEUIL 1

EDIT : la formule est là à titre d'exemple, évidemment si c'était cette condition autant la supprimer ^^
FEUIL 2

J'ai essayé de rajouter une ligne pour supprimer les lignes dont la cellule en colonne D est vide :

Feuil4.Range("D2:D" & [D65536].End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Cela me fluote la ligne. Je l'ai calée entre "Next" et "Feuil4.copy".
Qu'est-ce qui est mal fait ? Auriez vous une solution ?

Merci.

 

[Modeste]

Bonsoir,

On pourrait te rétorquer qu'il s'agit là d'une énième modification de ta demande initiale ... Mais on n'imagine sans doute pas dès le départ, les implications de ce qui apparaît comme anodin dans un premier temps (et puis il suffirait que Staple, 1600e du nom qué famille! entende un petit Donald Fagen pour qu'il pardonne tout )

D'autres (dont je ne suis pas, bien sûr! ) feraient remarquer que ce problème n'aurait pas été rencontré avec ma proposition, ni celle de klin89 (pense-je)

Ceci étant, ton instruction pourrait avantageusement faire l'objet de 3 petites modifs:

• ajout de Feuil4. devant [D65536]
• ajout d'un .Row juste derrière le (xlUp)
• la colonne D étant susceptible de contenir des cellules vides, il vaudrait mieux utiliser [A65536], plutôt que [D65536]

... Tu noteras aussi que si de multiples situations imprévues devaient survenir, il serait prudent de repenser le code. Y ajouter, au fur et à mesure, des instructions, vérifications et autres étapes supplémentaires risque de transformer la chose en usine à gaz.

 

[Saxophone]

Merci pour votre aide à tous.
Sujet résolu